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
81 import Control.Applicative
82 import Control.Applicative.Combinators
83 import Control.Concurrent
85 import Control.Monad.IO.Class
86 import Control.Exception
87 import Control.Lens hiding ((.=), List)
88 import qualified Data.Text as T
89 import qualified Data.Text.IO as T
92 import qualified Data.HashMap.Strict as HashMap
93 import qualified Data.Map as Map
95 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
96 import qualified Language.Haskell.LSP.Types as LSP
97 import Language.Haskell.LSP.Messages
98 import Language.Haskell.LSP.VFS
99 import Language.Haskell.LSP.Test.Compat
100 import Language.Haskell.LSP.Test.Decoding
101 import Language.Haskell.LSP.Test.Exceptions
102 import Language.Haskell.LSP.Test.Parsing
103 import Language.Haskell.LSP.Test.Session
104 import Language.Haskell.LSP.Test.Server
106 import System.Directory
107 import System.FilePath
108 import qualified Yi.Rope as Rope
110 -- | Starts a new session.
111 runSession :: String -- ^ The command to run the server.
112 -> FilePath -- ^ The filepath to the root directory for the session.
113 -> Session a -- ^ The session to run.
115 runSession = runSessionWithConfig def
117 -- | Starts a new sesion with a client with the specified capabilities.
118 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
119 -> String -- ^ The command to run the server.
120 -> FilePath -- ^ The filepath to the root directory for the session.
121 -> Session a -- ^ The session to run.
123 runSessionWithConfig config serverExe rootDir session = do
124 pid <- getCurrentProcessID
125 absRootDir <- canonicalizePath rootDir
127 let initializeParams = InitializeParams (Just pid)
128 (Just $ T.pack absRootDir)
129 (Just $ filePathToUri absRootDir)
131 (capabilities config)
133 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
134 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
136 -- Wrap the session around initialize and shutdown calls
137 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
139 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
141 initRspVar <- initRsp <$> ask
142 liftIO $ putMVar initRspVar initRspMsg
144 sendNotification Initialized InitializedParams
146 -- Run the actual test
149 sendNotification Exit ExitParams
153 -- | Listens to the server output, makes sure it matches the record and
154 -- signals any semaphores
155 listenServer :: Handle -> SessionContext -> IO ()
156 listenServer serverOut context = do
157 msgBytes <- getNextMessage serverOut
159 reqMap <- readMVar $ requestMap context
161 let msg = decodeFromServerMsg reqMap msgBytes
162 writeChan (messageChan context) (ServerMessage msg)
164 listenServer serverOut context
166 -- | The current text contents of a document.
167 documentContents :: TextDocumentIdentifier -> Session T.Text
168 documentContents doc = do
170 let file = vfs Map.! (doc ^. uri)
171 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
173 -- | Parses an ApplyEditRequest, checks that it is for the passed document
174 -- and returns the new content
175 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
176 getDocumentEdit doc = do
177 req <- message :: Session ApplyWorkspaceEditRequest
179 unless (checkDocumentChanges req || checkChanges req) $
180 liftIO $ throw (IncorrectApplyEditRequestException (show req))
184 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
185 checkDocumentChanges req =
186 let changes = req ^. params . edit . documentChanges
187 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
189 Just docs -> (doc ^. uri) `elem` docs
191 checkChanges :: ApplyWorkspaceEditRequest -> Bool
193 let mMap = req ^. params . edit . changes
194 in maybe False (HashMap.member (doc ^. uri)) mMap
196 -- | Sends a request to the server and waits for its response.
198 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
200 -- Note: will skip any messages in between the request and the response.
201 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
202 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
204 -- | Send a request to the server and wait for its response,
206 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
207 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
209 -- | Sends a request to the server without waiting on the response.
212 => ClientMethod -- ^ The request method.
213 -> params -- ^ The request parameters.
214 -> Session LspId -- ^ The id of the request that was sent.
215 sendRequest' method params = do
216 id <- curReqId <$> get
217 modify $ \c -> c { curReqId = nextId id }
219 let req = RequestMessage' "2.0" id method params
221 -- Update the request map
222 reqMap <- requestMap <$> ask
223 liftIO $ modifyMVar_ reqMap $
224 \r -> return $ updateRequestMap r id method
230 where nextId (IdInt i) = IdInt (i + 1)
231 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
233 -- | A custom type for request message that doesn't
234 -- need a response type, allows us to infer the request
235 -- message type without using proxies.
236 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
238 instance ToJSON a => ToJSON (RequestMessage' a) where
239 toJSON (RequestMessage' rpc id method params) =
240 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
243 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
244 sendRequestMessage req = do
245 -- Update the request map
246 reqMap <- requestMap <$> ask
247 liftIO $ modifyMVar_ reqMap $
248 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
252 -- | Sends a notification to the server.
253 sendNotification :: ToJSON a
254 => ClientMethod -- ^ The notification method.
255 -> a -- ^ The notification parameters.
258 -- | Open a virtual file if we send a did open text document notification
259 sendNotification TextDocumentDidOpen params = do
260 let params' = fromJust $ decode $ encode params
261 n :: DidOpenTextDocumentNotification
262 n = NotificationMessage "2.0" TextDocumentDidOpen params'
263 oldVFS <- vfs <$> get
264 newVFS <- liftIO $ openVFS oldVFS n
265 modify (\s -> s { vfs = newVFS })
268 -- | Close a virtual file if we send a close text document notification
269 sendNotification TextDocumentDidClose params = do
270 let params' = fromJust $ decode $ encode params
271 n :: DidCloseTextDocumentNotification
272 n = NotificationMessage "2.0" TextDocumentDidClose params'
273 oldVFS <- vfs <$> get
274 newVFS <- liftIO $ closeVFS oldVFS n
275 modify (\s -> s { vfs = newVFS })
278 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
280 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
281 sendNotification' = sendMessage
283 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
284 sendResponse = sendMessage
286 -- | Returns the initialize response that was received from the server.
287 -- The initialize requests and responses are not included the session,
288 -- so if you need to test it use this.
289 initializeResponse :: Session InitializeResponse
290 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
292 -- | Opens a text document and sends a notification to the client.
293 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
294 openDoc file languageId = do
295 item <- getDocItem file languageId
296 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
297 TextDocumentIdentifier <$> getDocUri file
299 -- | Reads in a text document as the first version.
300 getDocItem :: FilePath -- ^ The path to the text document to read in.
301 -> String -- ^ The language ID, e.g "haskell" for .hs files.
302 -> Session TextDocumentItem
303 getDocItem file languageId = do
305 let fp = rootDir context </> file
306 contents <- liftIO $ T.readFile fp
307 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
309 -- | Gets the Uri for the file corrected to the session directory.
310 getDocUri :: FilePath -> Session Uri
313 let fp = rootDir context </> file
314 return $ filePathToUri fp
316 waitForDiagnostics :: Session [Diagnostic]
317 waitForDiagnostics = do
318 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
319 let (List diags) = diagsNot ^. params . LSP.diagnostics
322 -- | Expects a 'PublishDiagnosticsNotification' and throws an
323 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
325 noDiagnostics :: Session ()
327 diagsNot <- message :: Session PublishDiagnosticsNotification
328 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
330 -- | Returns the symbols in a document.
331 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
332 getDocumentSymbols doc = do
333 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
334 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
335 let (Just (List symbols)) = mRes
338 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
339 getAllCodeActions doc = do
340 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
341 let ctx = CodeActionContext (List curDiags) Nothing
343 foldM (go ctx) [] curDiags
346 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
348 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
351 Just e -> throw (UnexpectedResponseError rspLid e)
353 let Just (List cmdOrCAs) = mRes
354 in return (acc ++ cmdOrCAs)
356 executeCommand :: Command -> Session ()
357 executeCommand cmd = do
358 let args = decode $ encode $ fromJust $ cmd ^. arguments
359 execParams = ExecuteCommandParams (cmd ^. command) args
360 sendRequest_ WorkspaceExecuteCommand execParams
362 executeCodeAction :: CodeAction -> Session ()
363 executeCodeAction action = do
364 maybe (return ()) handleEdit $ action ^. edit
365 maybe (return ()) executeCommand $ action ^. command
367 where handleEdit :: WorkspaceEdit -> Session ()
369 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
370 in updateState (ReqApplyWorkspaceEdit req)