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
97 import System.Directory
98 import System.FilePath
99 import qualified Yi.Rope as Rope
101 -- | Starts a new session.
102 runSession :: String -- ^ The command to run the server.
103 -> FilePath -- ^ The filepath to the root directory for the session.
104 -> Session a -- ^ The session to run.
106 runSession = runSessionWithConfig def
108 -- | Starts a new sesion with a client with the specified capabilities.
109 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
110 -> String -- ^ The command to run the server.
111 -> FilePath -- ^ The filepath to the root directory for the session.
112 -> Session a -- ^ The session to run.
114 runSessionWithConfig config serverExe rootDir session = do
115 pid <- getCurrentProcessID
116 absRootDir <- canonicalizePath rootDir
118 let initializeParams = InitializeParams (Just pid)
119 (Just $ T.pack absRootDir)
120 (Just $ filePathToUri absRootDir)
122 (capabilities config)
124 withServer serverExe $ \serverIn serverOut _ ->
125 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
127 -- Wrap the session around initialize and shutdown calls
128 sendRequest Initialize initializeParams
129 initRspMsg <- response :: Session InitializeResponse
131 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
133 initRspVar <- initRsp <$> ask
134 liftIO $ putMVar initRspVar initRspMsg
136 sendNotification Initialized InitializedParams
138 -- Run the actual test
141 sendNotification Exit ExitParams
145 -- | Listens to the server output, makes sure it matches the record and
146 -- signals any semaphores
147 listenServer :: Handle -> Session ()
148 listenServer serverOut = do
149 msgBytes <- liftIO $ getNextMessage serverOut
152 reqMap <- liftIO $ readMVar $ requestMap context
154 let msg = decodeFromServerMsg reqMap msgBytes
155 liftIO $ writeChan (messageChan context) msg
157 listenServer serverOut
159 -- | The current text contents of a document.
160 documentContents :: TextDocumentIdentifier -> Session T.Text
161 documentContents doc = do
163 let docUri = doc ^. uri
164 file <- case Map.lookup docUri vfs' of
165 Just file -> return file
167 openDoc (fromJust (uriToFilePath docUri)) ""
168 newVfs <- vfs <$> get
169 return $ newVfs Map.! docUri
170 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
172 -- | Parses an ApplyEditRequest, checks that it is for the passed document
173 -- and returns the new content
174 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
175 getDocumentEdit doc = do
176 req <- request :: Session ApplyWorkspaceEditRequest
178 unless (checkDocumentChanges req || checkChanges req) $
179 liftIO $ throw (IncorrectApplyEditRequestException (show req))
183 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
184 checkDocumentChanges req =
185 let changes = req ^. params . edit . documentChanges
186 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
188 Just docs -> (doc ^. uri) `elem` docs
190 checkChanges :: ApplyWorkspaceEditRequest -> Bool
192 let mMap = req ^. params . edit . changes
193 in maybe False (HashMap.member (doc ^. uri)) mMap
195 -- | Sends a request to the server.
198 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
199 -- TextDocumentDocumentSymbol
200 -- (DocumentSymbolParams docId)
204 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
205 ClientMethod -- ^ The request method.
206 -> params -- ^ The request parameters.
207 -> Session LspId -- ^ The id of the request that was sent.
208 sendRequest method params = do
209 id <- curReqId <$> get
210 modify $ \c -> c { curReqId = nextId id }
212 let req = RequestMessage' "2.0" id method params
214 -- Update the request map
215 reqMap <- requestMap <$> ask
216 liftIO $ modifyMVar_ reqMap $
217 \r -> return $ updateRequestMap r id method
223 where nextId (IdInt i) = IdInt (i + 1)
224 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
226 -- | A custom type for request message that doesn't
227 -- need a response type, allows us to infer the request
228 -- message type without using proxies.
229 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
231 instance ToJSON a => ToJSON (RequestMessage' a) where
232 toJSON (RequestMessage' rpc id method params) =
233 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
236 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
237 sendRequest' req = do
238 -- Update the request map
239 reqMap <- requestMap <$> ask
240 liftIO $ modifyMVar_ reqMap $
241 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
245 -- | Sends a notification to the server.
246 sendNotification :: ToJSON a
247 => ClientMethod -- ^ The notification method.
248 -> a -- ^ The notification parameters.
251 -- | Open a virtual file if we send a did open text document notification
252 sendNotification TextDocumentDidOpen params = do
253 let params' = fromJust $ decode $ encode params
254 n :: DidOpenTextDocumentNotification
255 n = NotificationMessage "2.0" TextDocumentDidOpen params'
256 oldVFS <- vfs <$> get
257 newVFS <- liftIO $ openVFS oldVFS n
258 modify (\s -> s { vfs = newVFS })
261 -- | Close a virtual file if we send a close text document notification
262 sendNotification TextDocumentDidClose params = do
263 let params' = fromJust $ decode $ encode params
264 n :: DidCloseTextDocumentNotification
265 n = NotificationMessage "2.0" TextDocumentDidClose params'
266 oldVFS <- vfs <$> get
267 newVFS <- liftIO $ closeVFS oldVFS n
268 modify (\s -> s { vfs = newVFS })
271 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
273 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
274 sendNotification' = sendMessage
276 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
277 sendResponse = sendMessage
279 sendMessage :: ToJSON a => a -> Session ()
281 h <- serverIn <$> ask
282 liftIO $ B.hPut h $ addHeader (encode msg)
284 -- | Returns the initialize response that was received from the server.
285 -- The initialize requests and responses are not included the session,
286 -- so if you need to test it use this.
287 initializeResponse :: Session InitializeResponse
288 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
290 -- | Opens a text document and sends a notification to the client.
291 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
292 openDoc file languageId = do
293 item <- getDocItem file languageId
294 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
295 TextDocumentIdentifier <$> getDocUri file
297 -- | Reads in a text document as the first version.
298 getDocItem :: FilePath -- ^ The path to the text document to read in.
299 -> String -- ^ The language ID, e.g "haskell" for .hs files.
300 -> Session TextDocumentItem
301 getDocItem file languageId = do
303 let fp = rootDir context </> file
304 contents <- liftIO $ T.readFile fp
305 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
307 -- | Gets the Uri for the file corrected to the session directory.
308 getDocUri :: FilePath -> Session Uri
311 let fp = rootDir context </> file
312 return $ filePathToUri fp
314 getDiagnostics :: Session [Diagnostic]
316 diagsNot <- notification :: Session PublishDiagnosticsNotification
317 let (List diags) = diagsNot ^. params . LSP.diagnostics
320 -- | Expects a 'PublishDiagnosticsNotification' and throws an
321 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
323 noDiagnostics :: Session ()
325 diagsNot <- notification :: Session PublishDiagnosticsNotification
326 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
328 -- | Returns the symbols in a document.
329 getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
330 getDocumentSymbols doc = do
331 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)