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(..)
39 , publishDiagnosticsNotification
72 import Control.Applicative
73 import Control.Applicative.Combinators
74 import Control.Concurrent
76 import Control.Monad.IO.Class
77 import Control.Exception
78 import Control.Lens hiding ((.=), List)
79 import qualified Data.Text as T
80 import qualified Data.Text.IO as T
82 import qualified Data.ByteString.Lazy.Char8 as B
84 import qualified Data.HashMap.Strict as HashMap
85 import qualified Data.Map as Map
87 import Language.Haskell.LSP.Types hiding (id, capabilities)
88 import qualified Language.Haskell.LSP.Types as LSP
89 import Language.Haskell.LSP.VFS
90 import Language.Haskell.LSP.Test.Compat
91 import Language.Haskell.LSP.Test.Decoding
92 import Language.Haskell.LSP.Test.Exceptions
93 import Language.Haskell.LSP.Test.Parsing
94 import Language.Haskell.LSP.Test.Session
95 import Language.Haskell.LSP.Test.Server
96 import System.Console.ANSI
98 import System.Directory
99 import System.FilePath
100 import qualified Yi.Rope as Rope
102 -- | Starts a new session.
103 runSession :: String -- ^ The command to run the server.
104 -> FilePath -- ^ The filepath to the root directory for the session.
105 -> Session a -- ^ The session to run.
107 runSession = runSessionWithConfig def
109 -- | Starts a new sesion with a client with the specified capabilities.
110 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
111 -> 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 runSessionWithConfig config serverExe rootDir session = do
116 pid <- getCurrentProcessID
117 absRootDir <- canonicalizePath rootDir
119 let initializeParams = InitializeParams (Just pid)
120 (Just $ T.pack absRootDir)
121 (Just $ filePathToUri absRootDir)
123 (capabilities config)
125 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
126 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
128 -- Wrap the session around initialize and shutdown calls
129 sendRequest Initialize initializeParams
130 initRspMsg <- response :: Session InitializeResponse
132 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
134 initRspVar <- initRsp <$> ask
135 liftIO $ putMVar initRspVar initRspMsg
137 sendNotification Initialized InitializedParams
139 -- Run the actual test
142 sendNotification Exit ExitParams
146 -- | Listens to the server output, makes sure it matches the record and
147 -- signals any semaphores
148 listenServer :: Handle -> Session ()
149 listenServer serverOut = do
150 msgBytes <- liftIO $ getNextMessage serverOut
153 reqMap <- liftIO $ readMVar $ requestMap context
155 let msg = decodeFromServerMsg reqMap msgBytes
156 liftIO $ writeChan (messageChan context) msg
158 listenServer serverOut
160 -- | The current text contents of a document.
161 documentContents :: TextDocumentIdentifier -> Session T.Text
162 documentContents doc = do
164 let file = vfs Map.! (doc ^. uri)
165 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
167 -- | Parses an ApplyEditRequest, checks that it is for the passed document
168 -- and returns the new content
169 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
170 getDocumentEdit doc = do
171 req <- request :: Session ApplyWorkspaceEditRequest
173 unless (checkDocumentChanges req || checkChanges req) $
174 liftIO $ throw (IncorrectApplyEditRequestException (show req))
178 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
179 checkDocumentChanges req =
180 let changes = req ^. params . edit . documentChanges
181 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
183 Just docs -> (doc ^. uri) `elem` docs
185 checkChanges :: ApplyWorkspaceEditRequest -> Bool
187 let mMap = req ^. params . edit . changes
188 in maybe False (HashMap.member (doc ^. uri)) mMap
190 -- | Sends a request to the server.
193 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
194 -- TextDocumentDocumentSymbol
195 -- (DocumentSymbolParams docId)
199 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
200 ClientMethod -- ^ The request method.
201 -> params -- ^ The request parameters.
202 -> Session LspId -- ^ The id of the request that was sent.
203 sendRequest method params = do
204 id <- curReqId <$> get
205 modify $ \c -> c { curReqId = nextId id }
207 let req = RequestMessage' "2.0" id method params
209 -- Update the request map
210 reqMap <- requestMap <$> ask
211 liftIO $ modifyMVar_ reqMap $
212 \r -> return $ updateRequestMap r id method
218 where nextId (IdInt i) = IdInt (i + 1)
219 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
221 -- | A custom type for request message that doesn't
222 -- need a response type, allows us to infer the request
223 -- message type without using proxies.
224 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
226 instance ToJSON a => ToJSON (RequestMessage' a) where
227 toJSON (RequestMessage' rpc id method params) =
228 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
231 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
232 sendRequest' req = do
233 -- Update the request map
234 reqMap <- requestMap <$> ask
235 liftIO $ modifyMVar_ reqMap $
236 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
240 -- | Sends a notification to the server.
241 sendNotification :: ToJSON a
242 => ClientMethod -- ^ The notification method.
243 -> a -- ^ The notification parameters.
246 -- | Open a virtual file if we send a did open text document notification
247 sendNotification TextDocumentDidOpen params = do
248 let params' = fromJust $ decode $ encode params
249 n :: DidOpenTextDocumentNotification
250 n = NotificationMessage "2.0" TextDocumentDidOpen params'
251 oldVFS <- vfs <$> get
252 newVFS <- liftIO $ openVFS oldVFS n
253 modify (\s -> s { vfs = newVFS })
256 -- | Close a virtual file if we send a close text document notification
257 sendNotification TextDocumentDidClose params = do
258 let params' = fromJust $ decode $ encode params
259 n :: DidCloseTextDocumentNotification
260 n = NotificationMessage "2.0" TextDocumentDidClose params'
261 oldVFS <- vfs <$> get
262 newVFS <- liftIO $ closeVFS oldVFS n
263 modify (\s -> s { vfs = newVFS })
266 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
268 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
269 sendNotification' = sendMessage
271 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
272 sendResponse = sendMessage
274 sendMessage :: ToJSON a => a -> Session ()
276 h <- serverIn <$> ask
277 let encoded = encode msg
280 setSGR [SetColor Foreground Vivid Cyan]
281 putStrLn $ "--> " ++ B.unpack encoded
284 B.hPut h (addHeader encoded)
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 getDiagnostics :: Session [Diagnostic]
320 diagsNot <- 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 DocumentSymbolsResponse
334 getDocumentSymbols doc = do
335 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)