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(..)
41 , publishDiagnosticsNotification
82 import Control.Applicative
83 import Control.Applicative.Combinators
84 import Control.Concurrent
86 import Control.Monad.IO.Class
87 import Control.Exception
88 import Control.Lens hiding ((.=), List)
89 import qualified Data.Text as T
90 import qualified Data.Text.IO as T
93 import qualified Data.HashMap.Strict as HashMap
94 import qualified Data.Map as Map
96 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
97 import qualified Language.Haskell.LSP.Types as LSP
98 import Language.Haskell.LSP.Messages
99 import Language.Haskell.LSP.VFS
100 import Language.Haskell.LSP.Test.Compat
101 import Language.Haskell.LSP.Test.Decoding
102 import Language.Haskell.LSP.Test.Exceptions
103 import Language.Haskell.LSP.Test.Parsing
104 import Language.Haskell.LSP.Test.Session
105 import Language.Haskell.LSP.Test.Server
107 import System.Directory
108 import System.FilePath
109 import qualified Yi.Rope as Rope
111 -- | Starts a new session.
112 runSession :: String -- ^ The command to run the server.
113 -> FilePath -- ^ The filepath to the root directory for the session.
114 -> Session a -- ^ The session to run.
116 runSession = runSessionWithConfig def
118 -- | Starts a new sesion with a client with the specified capabilities.
119 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
120 -> String -- ^ The command to run the server.
121 -> FilePath -- ^ The filepath to the root directory for the session.
122 -> Session a -- ^ The session to run.
124 runSessionWithConfig config serverExe rootDir session = do
125 pid <- getCurrentProcessID
126 absRootDir <- canonicalizePath rootDir
128 let initializeParams = InitializeParams (Just pid)
129 (Just $ T.pack absRootDir)
130 (Just $ filePathToUri absRootDir)
132 (capabilities config)
134 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
135 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
137 -- Wrap the session around initialize and shutdown calls
138 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
140 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
142 initRspVar <- initRsp <$> ask
143 liftIO $ putMVar initRspVar initRspMsg
145 sendNotification Initialized InitializedParams
147 -- Run the actual test
150 sendNotification Exit ExitParams
154 -- | Listens to the server output, makes sure it matches the record and
155 -- signals any semaphores
156 listenServer :: Handle -> SessionContext -> IO ()
157 listenServer serverOut context = do
158 msgBytes <- getNextMessage serverOut
160 reqMap <- readMVar $ requestMap context
162 let msg = decodeFromServerMsg reqMap msgBytes
163 writeChan (messageChan context) (ServerMessage msg)
165 listenServer serverOut context
167 -- | The current text contents of a document.
168 documentContents :: TextDocumentIdentifier -> Session T.Text
169 documentContents doc = do
171 let file = vfs Map.! (doc ^. uri)
172 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
174 -- | Parses an ApplyEditRequest, checks that it is for the passed document
175 -- and returns the new content
176 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
177 getDocumentEdit doc = do
178 req <- message :: Session ApplyWorkspaceEditRequest
180 unless (checkDocumentChanges req || checkChanges req) $
181 liftIO $ throw (IncorrectApplyEditRequestException (show req))
185 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
186 checkDocumentChanges req =
187 let changes = req ^. params . edit . documentChanges
188 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
190 Just docs -> (doc ^. uri) `elem` docs
192 checkChanges :: ApplyWorkspaceEditRequest -> Bool
194 let mMap = req ^. params . edit . changes
195 in maybe False (HashMap.member (doc ^. uri)) mMap
197 -- | Sends a request to the server and waits for its response.
199 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
201 -- Note: will skip any messages in between the request and the response.
202 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
203 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
205 -- | Send a request to the server and wait for its response,
207 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
208 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
210 -- | Sends a request to the server without waiting on the response.
213 => ClientMethod -- ^ The request method.
214 -> params -- ^ The request parameters.
215 -> Session LspId -- ^ The id of the request that was sent.
216 sendRequest' method params = do
217 id <- curReqId <$> get
218 modify $ \c -> c { curReqId = nextId id }
220 let req = RequestMessage' "2.0" id method params
222 -- Update the request map
223 reqMap <- requestMap <$> ask
224 liftIO $ modifyMVar_ reqMap $
225 \r -> return $ updateRequestMap r id method
231 where nextId (IdInt i) = IdInt (i + 1)
232 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
234 -- | A custom type for request message that doesn't
235 -- need a response type, allows us to infer the request
236 -- message type without using proxies.
237 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
239 instance ToJSON a => ToJSON (RequestMessage' a) where
240 toJSON (RequestMessage' rpc id method params) =
241 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
244 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
245 sendRequestMessage req = do
246 -- Update the request map
247 reqMap <- requestMap <$> ask
248 liftIO $ modifyMVar_ reqMap $
249 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
253 -- | Sends a notification to the server.
254 sendNotification :: ToJSON a
255 => ClientMethod -- ^ The notification method.
256 -> a -- ^ The notification parameters.
259 -- | Open a virtual file if we send a did open text document notification
260 sendNotification TextDocumentDidOpen params = do
261 let params' = fromJust $ decode $ encode params
262 n :: DidOpenTextDocumentNotification
263 n = NotificationMessage "2.0" TextDocumentDidOpen params'
264 oldVFS <- vfs <$> get
265 newVFS <- liftIO $ openVFS oldVFS n
266 modify (\s -> s { vfs = newVFS })
269 -- | Close a virtual file if we send a close text document notification
270 sendNotification TextDocumentDidClose params = do
271 let params' = fromJust $ decode $ encode params
272 n :: DidCloseTextDocumentNotification
273 n = NotificationMessage "2.0" TextDocumentDidClose params'
274 oldVFS <- vfs <$> get
275 newVFS <- liftIO $ closeVFS oldVFS n
276 modify (\s -> s { vfs = newVFS })
279 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
281 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
282 sendNotification' = sendMessage
284 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
285 sendResponse = sendMessage
287 -- | Returns the initialize response that was received from the server.
288 -- The initialize requests and responses are not included the session,
289 -- so if you need to test it use this.
290 initializeResponse :: Session InitializeResponse
291 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
293 -- | Opens a text document and sends a notification to the client.
294 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
295 openDoc file languageId = do
296 item <- getDocItem file languageId
297 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
298 TextDocumentIdentifier <$> getDocUri file
300 -- | Reads in a text document as the first version.
301 getDocItem :: FilePath -- ^ The path to the text document to read in.
302 -> String -- ^ The language ID, e.g "haskell" for .hs files.
303 -> Session TextDocumentItem
304 getDocItem file languageId = do
306 let fp = rootDir context </> file
307 contents <- liftIO $ T.readFile fp
308 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
310 -- | Gets the Uri for the file corrected to the session directory.
311 getDocUri :: FilePath -> Session Uri
314 let fp = rootDir context </> file
315 return $ filePathToUri fp
317 waitForDiagnostics :: Session [Diagnostic]
318 waitForDiagnostics = do
319 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
320 let (List diags) = diagsNot ^. params . LSP.diagnostics
323 -- | Expects a 'PublishDiagnosticsNotification' and throws an
324 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
326 noDiagnostics :: Session ()
328 diagsNot <- message :: Session PublishDiagnosticsNotification
329 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
331 -- | Returns the symbols in a document.
332 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
333 getDocumentSymbols doc = do
334 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
335 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
336 let (Just (List symbols)) = mRes
339 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
340 getAllCodeActions doc = do
341 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
342 let ctx = CodeActionContext (List curDiags) Nothing
344 foldM (go ctx) [] curDiags
347 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
349 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
352 Just e -> throw (UnexpectedResponseError rspLid e)
354 let Just (List cmdOrCAs) = mRes
355 in return (acc ++ cmdOrCAs)
357 executeCommand :: Command -> Session ()
358 executeCommand cmd = do
359 let args = decode $ encode $ fromJust $ cmd ^. arguments
360 execParams = ExecuteCommandParams (cmd ^. command) args
361 sendRequest_ WorkspaceExecuteCommand execParams
363 executeCodeAction :: CodeAction -> Session ()
364 executeCodeAction action = do
365 maybe (return ()) handleEdit $ action ^. edit
366 maybe (return ()) executeCommand $ action ^. command
368 where handleEdit :: WorkspaceEdit -> Session ()
370 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
371 in updateState (ReqApplyWorkspaceEdit req)