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
76 import Control.Applicative
77 import Control.Applicative.Combinators
78 import Control.Concurrent
80 import Control.Monad.IO.Class
81 import Control.Exception
82 import Control.Lens hiding ((.=), List)
83 import qualified Data.Text as T
84 import qualified Data.Text.IO as T
86 import qualified Data.ByteString.Lazy.Char8 as B
88 import qualified Data.HashMap.Strict as HashMap
89 import qualified Data.Map as Map
91 import Language.Haskell.LSP.Types hiding (id, capabilities)
92 import qualified Language.Haskell.LSP.Types as LSP
93 import Language.Haskell.LSP.VFS
94 import Language.Haskell.LSP.Test.Compat
95 import Language.Haskell.LSP.Test.Decoding
96 import Language.Haskell.LSP.Test.Exceptions
97 import Language.Haskell.LSP.Test.Parsing
98 import Language.Haskell.LSP.Test.Session
99 import Language.Haskell.LSP.Test.Server
100 import System.Console.ANSI
102 import System.Directory
103 import System.FilePath
104 import qualified Yi.Rope as Rope
106 -- | Starts a new session.
107 runSession :: String -- ^ The command to run the server.
108 -> FilePath -- ^ The filepath to the root directory for the session.
109 -> Session a -- ^ The session to run.
111 runSession = runSessionWithConfig def
113 -- | Starts a new sesion with a client with the specified capabilities.
114 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
115 -> String -- ^ The command to run the server.
116 -> FilePath -- ^ The filepath to the root directory for the session.
117 -> Session a -- ^ The session to run.
119 runSessionWithConfig config serverExe rootDir session = do
120 pid <- getCurrentProcessID
121 absRootDir <- canonicalizePath rootDir
123 let initializeParams = InitializeParams (Just pid)
124 (Just $ T.pack absRootDir)
125 (Just $ filePathToUri absRootDir)
127 (capabilities config)
129 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
130 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
132 -- Wrap the session around initialize and shutdown calls
133 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
135 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
137 initRspVar <- initRsp <$> ask
138 liftIO $ putMVar initRspVar initRspMsg
140 sendNotification Initialized InitializedParams
142 -- Run the actual test
145 sendNotification Exit ExitParams
149 -- | Listens to the server output, makes sure it matches the record and
150 -- signals any semaphores
151 listenServer :: Handle -> Session ()
152 listenServer serverOut = do
153 msgBytes <- liftIO $ getNextMessage serverOut
156 reqMap <- liftIO $ readMVar $ requestMap context
158 let msg = decodeFromServerMsg reqMap msgBytes
159 liftIO $ writeChan (messageChan context) msg
161 listenServer serverOut
163 -- | The current text contents of a document.
164 documentContents :: TextDocumentIdentifier -> Session T.Text
165 documentContents doc = do
167 let file = vfs Map.! (doc ^. uri)
168 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
170 -- | Parses an ApplyEditRequest, checks that it is for the passed document
171 -- and returns the new content
172 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
173 getDocumentEdit doc = do
174 req <- request :: Session ApplyWorkspaceEditRequest
176 unless (checkDocumentChanges req || checkChanges req) $
177 liftIO $ throw (IncorrectApplyEditRequestException (show req))
181 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
182 checkDocumentChanges req =
183 let changes = req ^. params . edit . documentChanges
184 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
186 Just docs -> (doc ^. uri) `elem` docs
188 checkChanges :: ApplyWorkspaceEditRequest -> Bool
190 let mMap = req ^. params . edit . changes
191 in maybe False (HashMap.member (doc ^. uri)) mMap
193 -- | Sends a request to the server and waits for its response.
195 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
197 -- Note: will skip any messages in between the request and the response.
198 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
199 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
201 -- | Send a request to the server and wait for its response,
203 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
204 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
206 -- | Sends a request to the server without waiting on the response.
209 => ClientMethod -- ^ The request method.
210 -> params -- ^ The request parameters.
211 -> Session LspId -- ^ The id of the request that was sent.
212 sendRequest' method params = do
213 id <- curReqId <$> get
214 modify $ \c -> c { curReqId = nextId id }
216 let req = RequestMessage' "2.0" id method params
218 -- Update the request map
219 reqMap <- requestMap <$> ask
220 liftIO $ modifyMVar_ reqMap $
221 \r -> return $ updateRequestMap r id method
227 where nextId (IdInt i) = IdInt (i + 1)
228 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
230 -- | A custom type for request message that doesn't
231 -- need a response type, allows us to infer the request
232 -- message type without using proxies.
233 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
235 instance ToJSON a => ToJSON (RequestMessage' a) where
236 toJSON (RequestMessage' rpc id method params) =
237 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
240 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
241 sendRequestMessage req = do
242 -- Update the request map
243 reqMap <- requestMap <$> ask
244 liftIO $ modifyMVar_ reqMap $
245 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
249 -- | Sends a notification to the server.
250 sendNotification :: ToJSON a
251 => ClientMethod -- ^ The notification method.
252 -> a -- ^ The notification parameters.
255 -- | Open a virtual file if we send a did open text document notification
256 sendNotification TextDocumentDidOpen params = do
257 let params' = fromJust $ decode $ encode params
258 n :: DidOpenTextDocumentNotification
259 n = NotificationMessage "2.0" TextDocumentDidOpen params'
260 oldVFS <- vfs <$> get
261 newVFS <- liftIO $ openVFS oldVFS n
262 modify (\s -> s { vfs = newVFS })
265 -- | Close a virtual file if we send a close text document notification
266 sendNotification TextDocumentDidClose params = do
267 let params' = fromJust $ decode $ encode params
268 n :: DidCloseTextDocumentNotification
269 n = NotificationMessage "2.0" TextDocumentDidClose params'
270 oldVFS <- vfs <$> get
271 newVFS <- liftIO $ closeVFS oldVFS n
272 modify (\s -> s { vfs = newVFS })
275 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
277 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
278 sendNotification' = sendMessage
280 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
281 sendResponse = sendMessage
283 sendMessage :: ToJSON a => a -> Session ()
285 h <- serverIn <$> ask
286 let encoded = encode msg
289 setSGR [SetColor Foreground Vivid Cyan]
290 putStrLn $ "--> " ++ B.unpack encoded
293 B.hPut h (addHeader encoded)
297 -- | Returns the initialize response that was received from the server.
298 -- The initialize requests and responses are not included the session,
299 -- so if you need to test it use this.
300 initializeResponse :: Session InitializeResponse
301 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
303 -- | Opens a text document and sends a notification to the client.
304 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
305 openDoc file languageId = do
306 item <- getDocItem file languageId
307 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
308 TextDocumentIdentifier <$> getDocUri file
310 -- | Reads in a text document as the first version.
311 getDocItem :: FilePath -- ^ The path to the text document to read in.
312 -> String -- ^ The language ID, e.g "haskell" for .hs files.
313 -> Session TextDocumentItem
314 getDocItem file languageId = do
316 let fp = rootDir context </> file
317 contents <- liftIO $ T.readFile fp
318 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
320 -- | Gets the Uri for the file corrected to the session directory.
321 getDocUri :: FilePath -> Session Uri
324 let fp = rootDir context </> file
325 return $ filePathToUri fp
327 waitForDiagnostics :: Session [Diagnostic]
328 waitForDiagnostics = do
329 diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
330 let (List diags) = diagsNot ^. params . LSP.diagnostics
333 -- | Expects a 'PublishDiagnosticsNotification' and throws an
334 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
336 noDiagnostics :: Session ()
338 diagsNot <- notification :: Session PublishDiagnosticsNotification
339 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
341 -- | Returns the symbols in a document.
342 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
343 getDocumentSymbols doc = do
344 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
345 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
346 let (Just (List symbols)) = mRes
349 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
350 getAllCodeActions doc = do
351 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
352 let ctx = CodeActionContext (List curDiags) Nothing
354 foldM (go ctx) [] curDiags
357 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
359 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
362 Just e -> throw (UnexpectedResponseError rspLid e)
364 let Just (List cmdOrCAs) = mRes
365 in return (acc ++ cmdOrCAs)