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 , MonadSessionConfig(..)
23 , SessionException(..)
42 , publishDiagnosticsNotification
83 import Control.Applicative
84 import Control.Applicative.Combinators
85 import Control.Concurrent
87 import Control.Monad.IO.Class
88 import Control.Exception
89 import Control.Lens hiding ((.=), List)
90 import qualified Data.Text as T
91 import qualified Data.Text.IO as T
94 import qualified Data.HashMap.Strict as HashMap
95 import qualified Data.Map as Map
97 import Language.Haskell.LSP.Types hiding (id, capabilities)
98 import qualified Language.Haskell.LSP.Types as LSP
99 import Language.Haskell.LSP.Messages
100 import Language.Haskell.LSP.VFS
101 import Language.Haskell.LSP.Test.Compat
102 import Language.Haskell.LSP.Test.Decoding
103 import Language.Haskell.LSP.Test.Exceptions
104 import Language.Haskell.LSP.Test.Parsing
105 import Language.Haskell.LSP.Test.Session
106 import Language.Haskell.LSP.Test.Server
108 import System.Directory
109 import System.FilePath
110 import qualified Yi.Rope as Rope
112 -- | Starts a new session.
113 runSession :: String -- ^ The command to run the server.
114 -> FilePath -- ^ The filepath to the root directory for the session.
115 -> Session a -- ^ The session to run.
117 runSession = runSessionWithConfig def
119 -- | Starts a new sesion with a client with the specified capabilities.
120 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
121 -> String -- ^ The command to run the server.
122 -> FilePath -- ^ The filepath to the root directory for the session.
123 -> Session a -- ^ The session to run.
125 runSessionWithConfig config serverExe rootDir session = do
126 pid <- getCurrentProcessID
127 absRootDir <- canonicalizePath rootDir
129 let initializeParams = InitializeParams (Just pid)
130 (Just $ T.pack absRootDir)
131 (Just $ filePathToUri absRootDir)
133 (capabilities config)
135 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
136 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
138 -- Wrap the session around initialize and shutdown calls
139 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
141 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
143 initRspVar <- initRsp <$> ask
144 liftIO $ putMVar initRspVar initRspMsg
146 sendNotification Initialized InitializedParams
148 -- Run the actual test
151 sendNotification Exit ExitParams
155 -- | Listens to the server output, makes sure it matches the record and
156 -- signals any semaphores
157 listenServer :: Handle -> Session ()
158 listenServer serverOut = do
159 msgBytes <- liftIO $ getNextMessage serverOut
162 reqMap <- liftIO $ readMVar $ requestMap context
164 let msg = decodeFromServerMsg reqMap msgBytes
165 liftIO $ writeChan (messageChan context) msg
167 listenServer serverOut
169 -- | The current text contents of a document.
170 documentContents :: TextDocumentIdentifier -> Session T.Text
171 documentContents doc = do
173 let file = vfs Map.! (doc ^. uri)
174 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
176 -- | Parses an ApplyEditRequest, checks that it is for the passed document
177 -- and returns the new content
178 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
179 getDocumentEdit doc = do
180 req <- request :: Session ApplyWorkspaceEditRequest
182 unless (checkDocumentChanges req || checkChanges req) $
183 liftIO $ throw (IncorrectApplyEditRequestException (show req))
187 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
188 checkDocumentChanges req =
189 let changes = req ^. params . edit . documentChanges
190 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
192 Just docs -> (doc ^. uri) `elem` docs
194 checkChanges :: ApplyWorkspaceEditRequest -> Bool
196 let mMap = req ^. params . edit . changes
197 in maybe False (HashMap.member (doc ^. uri)) mMap
199 -- | Sends a request to the server and waits for its response.
201 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
203 -- Note: will skip any messages in between the request and the response.
204 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
205 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
207 -- | Send a request to the server and wait for its response,
209 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
210 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
212 -- | Sends a request to the server without waiting on the response.
215 => ClientMethod -- ^ The request method.
216 -> params -- ^ The request parameters.
217 -> Session LspId -- ^ The id of the request that was sent.
218 sendRequest' method params = do
219 id <- curReqId <$> get
220 modify $ \c -> c { curReqId = nextId id }
222 let req = RequestMessage' "2.0" id method params
224 -- Update the request map
225 reqMap <- requestMap <$> ask
226 liftIO $ modifyMVar_ reqMap $
227 \r -> return $ updateRequestMap r id method
233 where nextId (IdInt i) = IdInt (i + 1)
234 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
236 -- | A custom type for request message that doesn't
237 -- need a response type, allows us to infer the request
238 -- message type without using proxies.
239 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
241 instance ToJSON a => ToJSON (RequestMessage' a) where
242 toJSON (RequestMessage' rpc id method params) =
243 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
246 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
247 sendRequestMessage req = do
248 -- Update the request map
249 reqMap <- requestMap <$> ask
250 liftIO $ modifyMVar_ reqMap $
251 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
255 -- | Sends a notification to the server.
256 sendNotification :: ToJSON a
257 => ClientMethod -- ^ The notification method.
258 -> a -- ^ The notification parameters.
261 -- | Open a virtual file if we send a did open text document notification
262 sendNotification TextDocumentDidOpen params = do
263 let params' = fromJust $ decode $ encode params
264 n :: DidOpenTextDocumentNotification
265 n = NotificationMessage "2.0" TextDocumentDidOpen params'
266 oldVFS <- vfs <$> get
267 newVFS <- liftIO $ openVFS oldVFS n
268 modify (\s -> s { vfs = newVFS })
271 -- | Close a virtual file if we send a close text document notification
272 sendNotification TextDocumentDidClose params = do
273 let params' = fromJust $ decode $ encode params
274 n :: DidCloseTextDocumentNotification
275 n = NotificationMessage "2.0" TextDocumentDidClose params'
276 oldVFS <- vfs <$> get
277 newVFS <- liftIO $ closeVFS oldVFS n
278 modify (\s -> s { vfs = newVFS })
281 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
283 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
284 sendNotification' = sendMessage
286 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
287 sendResponse = sendMessage
289 -- | Returns the initialize response that was received from the server.
290 -- The initialize requests and responses are not included the session,
291 -- so if you need to test it use this.
292 initializeResponse :: Session InitializeResponse
293 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
295 -- | Opens a text document and sends a notification to the client.
296 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
297 openDoc file languageId = do
298 item <- getDocItem file languageId
299 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
300 TextDocumentIdentifier <$> getDocUri file
302 -- | Reads in a text document as the first version.
303 getDocItem :: FilePath -- ^ The path to the text document to read in.
304 -> String -- ^ The language ID, e.g "haskell" for .hs files.
305 -> Session TextDocumentItem
306 getDocItem file languageId = do
308 let fp = rootDir context </> file
309 contents <- liftIO $ T.readFile fp
310 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
312 -- | Gets the Uri for the file corrected to the session directory.
313 getDocUri :: FilePath -> Session Uri
316 let fp = rootDir context </> file
317 return $ filePathToUri fp
319 waitForDiagnostics :: Session [Diagnostic]
320 waitForDiagnostics = do
321 diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
322 let (List diags) = diagsNot ^. params . LSP.diagnostics
325 -- | Expects a 'PublishDiagnosticsNotification' and throws an
326 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
328 noDiagnostics :: Session ()
330 diagsNot <- notification :: Session PublishDiagnosticsNotification
331 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
333 -- | Returns the symbols in a document.
334 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
335 getDocumentSymbols doc = do
336 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
337 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
338 let (Just (List symbols)) = mRes
341 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
342 getAllCodeActions doc = do
343 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
344 let ctx = CodeActionContext (List curDiags) Nothing
346 foldM (go ctx) [] curDiags
349 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
351 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
354 Just e -> throw (UnexpectedResponseError rspLid e)
356 let Just (List cmdOrCAs) = mRes
357 in return (acc ++ cmdOrCAs)
359 executeCommand :: Command -> Session ()
360 executeCommand cmd = do
361 let args = decode $ encode $ fromJust $ cmd ^. arguments
362 execParams = ExecuteCommandParams (cmd ^. command) args
363 sendRequest_ WorkspaceExecuteCommand execParams
365 executeCodeAction :: CodeAction -> Session ()
366 executeCodeAction action = do
367 maybe (return ()) handleEdit $ action ^. edit
368 maybe (return ()) executeCommand $ action ^. command
370 where handleEdit :: WorkspaceEdit -> Session ()
372 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
373 in processMessage (ReqApplyWorkspaceEdit req)