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 -> SessionContext -> IO ()
158 listenServer serverOut context = do
159 msgBytes <- getNextMessage serverOut
161 reqMap <- readMVar $ requestMap context
163 let msg = decodeFromServerMsg reqMap msgBytes
164 writeChan (messageChan context) msg
166 listenServer serverOut context
168 -- | The current text contents of a document.
169 documentContents :: TextDocumentIdentifier -> Session T.Text
170 documentContents doc = do
172 let file = vfs Map.! (doc ^. uri)
173 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
175 -- | Parses an ApplyEditRequest, checks that it is for the passed document
176 -- and returns the new content
177 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
178 getDocumentEdit doc = do
179 req <- request :: Session ApplyWorkspaceEditRequest
181 unless (checkDocumentChanges req || checkChanges req) $
182 liftIO $ throw (IncorrectApplyEditRequestException (show req))
186 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
187 checkDocumentChanges req =
188 let changes = req ^. params . edit . documentChanges
189 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
191 Just docs -> (doc ^. uri) `elem` docs
193 checkChanges :: ApplyWorkspaceEditRequest -> Bool
195 let mMap = req ^. params . edit . changes
196 in maybe False (HashMap.member (doc ^. uri)) mMap
198 -- | Sends a request to the server and waits for its response.
200 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
202 -- Note: will skip any messages in between the request and the response.
203 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
204 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
206 -- | Send a request to the server and wait for its response,
208 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
209 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
211 -- | Sends a request to the server without waiting on the response.
214 => ClientMethod -- ^ The request method.
215 -> params -- ^ The request parameters.
216 -> Session LspId -- ^ The id of the request that was sent.
217 sendRequest' method params = do
218 id <- curReqId <$> get
219 modify $ \c -> c { curReqId = nextId id }
221 let req = RequestMessage' "2.0" id method params
223 -- Update the request map
224 reqMap <- requestMap <$> ask
225 liftIO $ modifyMVar_ reqMap $
226 \r -> return $ updateRequestMap r id method
232 where nextId (IdInt i) = IdInt (i + 1)
233 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
235 -- | A custom type for request message that doesn't
236 -- need a response type, allows us to infer the request
237 -- message type without using proxies.
238 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
240 instance ToJSON a => ToJSON (RequestMessage' a) where
241 toJSON (RequestMessage' rpc id method params) =
242 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
245 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
246 sendRequestMessage req = do
247 -- Update the request map
248 reqMap <- requestMap <$> ask
249 liftIO $ modifyMVar_ reqMap $
250 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
254 -- | Sends a notification to the server.
255 sendNotification :: ToJSON a
256 => ClientMethod -- ^ The notification method.
257 -> a -- ^ The notification parameters.
260 -- | Open a virtual file if we send a did open text document notification
261 sendNotification TextDocumentDidOpen params = do
262 let params' = fromJust $ decode $ encode params
263 n :: DidOpenTextDocumentNotification
264 n = NotificationMessage "2.0" TextDocumentDidOpen params'
265 oldVFS <- vfs <$> get
266 newVFS <- liftIO $ openVFS oldVFS n
267 modify (\s -> s { vfs = newVFS })
270 -- | Close a virtual file if we send a close text document notification
271 sendNotification TextDocumentDidClose params = do
272 let params' = fromJust $ decode $ encode params
273 n :: DidCloseTextDocumentNotification
274 n = NotificationMessage "2.0" TextDocumentDidClose params'
275 oldVFS <- vfs <$> get
276 newVFS <- liftIO $ closeVFS oldVFS n
277 modify (\s -> s { vfs = newVFS })
280 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
282 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
283 sendNotification' = sendMessage
285 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
286 sendResponse = sendMessage
288 -- | Returns the initialize response that was received from the server.
289 -- The initialize requests and responses are not included the session,
290 -- so if you need to test it use this.
291 initializeResponse :: Session InitializeResponse
292 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
294 -- | Opens a text document and sends a notification to the client.
295 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
296 openDoc file languageId = do
297 item <- getDocItem file languageId
298 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
299 TextDocumentIdentifier <$> getDocUri file
301 -- | Reads in a text document as the first version.
302 getDocItem :: FilePath -- ^ The path to the text document to read in.
303 -> String -- ^ The language ID, e.g "haskell" for .hs files.
304 -> Session TextDocumentItem
305 getDocItem file languageId = do
307 let fp = rootDir context </> file
308 contents <- liftIO $ T.readFile fp
309 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
311 -- | Gets the Uri for the file corrected to the session directory.
312 getDocUri :: FilePath -> Session Uri
315 let fp = rootDir context </> file
316 return $ filePathToUri fp
318 waitForDiagnostics :: Session [Diagnostic]
319 waitForDiagnostics = do
320 diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
321 let (List diags) = diagsNot ^. params . LSP.diagnostics
324 -- | Expects a 'PublishDiagnosticsNotification' and throws an
325 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
327 noDiagnostics :: Session ()
329 diagsNot <- notification :: Session PublishDiagnosticsNotification
330 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
332 -- | Returns the symbols in a document.
333 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
334 getDocumentSymbols doc = do
335 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
336 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
337 let (Just (List symbols)) = mRes
340 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
341 getAllCodeActions doc = do
342 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
343 let ctx = CodeActionContext (List curDiags) Nothing
345 foldM (go ctx) [] curDiags
348 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
350 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
353 Just e -> throw (UnexpectedResponseError rspLid e)
355 let Just (List cmdOrCAs) = mRes
356 in return (acc ++ cmdOrCAs)
358 executeCommand :: Command -> Session ()
359 executeCommand cmd = do
360 let args = decode $ encode $ fromJust $ cmd ^. arguments
361 execParams = ExecuteCommandParams (cmd ^. command) args
362 sendRequest_ WorkspaceExecuteCommand execParams
364 executeCodeAction :: CodeAction -> Session ()
365 executeCodeAction action = do
366 maybe (return ()) handleEdit $ action ^. edit
367 maybe (return ()) executeCommand $ action ^. command
369 where handleEdit :: WorkspaceEdit -> Session ()
371 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
372 in processMessage (ReqApplyWorkspaceEdit req)