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 (logStdErr config) $ \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 file = vfs Map.! (doc ^. uri)
164 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
166 -- | Parses an ApplyEditRequest, checks that it is for the passed document
167 -- and returns the new content
168 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
169 getDocumentEdit doc = do
170 req <- request :: Session ApplyWorkspaceEditRequest
172 unless (checkDocumentChanges req || checkChanges req) $
173 liftIO $ throw (IncorrectApplyEditRequestException (show req))
177 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
178 checkDocumentChanges req =
179 let changes = req ^. params . edit . documentChanges
180 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
182 Just docs -> (doc ^. uri) `elem` docs
184 checkChanges :: ApplyWorkspaceEditRequest -> Bool
186 let mMap = req ^. params . edit . changes
187 in maybe False (HashMap.member (doc ^. uri)) mMap
189 -- | Sends a request to the server.
192 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
193 -- TextDocumentDocumentSymbol
194 -- (DocumentSymbolParams docId)
198 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
199 ClientMethod -- ^ The request method.
200 -> params -- ^ The request parameters.
201 -> Session LspId -- ^ The id of the request that was sent.
202 sendRequest method params = do
203 id <- curReqId <$> get
204 modify $ \c -> c { curReqId = nextId id }
206 let req = RequestMessage' "2.0" id method params
208 -- Update the request map
209 reqMap <- requestMap <$> ask
210 liftIO $ modifyMVar_ reqMap $
211 \r -> return $ updateRequestMap r id method
217 where nextId (IdInt i) = IdInt (i + 1)
218 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
220 -- | A custom type for request message that doesn't
221 -- need a response type, allows us to infer the request
222 -- message type without using proxies.
223 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
225 instance ToJSON a => ToJSON (RequestMessage' a) where
226 toJSON (RequestMessage' rpc id method params) =
227 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
230 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
231 sendRequest' req = do
232 -- Update the request map
233 reqMap <- requestMap <$> ask
234 liftIO $ modifyMVar_ reqMap $
235 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
239 -- | Sends a notification to the server.
240 sendNotification :: ToJSON a
241 => ClientMethod -- ^ The notification method.
242 -> a -- ^ The notification parameters.
245 -- | Open a virtual file if we send a did open text document notification
246 sendNotification TextDocumentDidOpen params = do
247 let params' = fromJust $ decode $ encode params
248 n :: DidOpenTextDocumentNotification
249 n = NotificationMessage "2.0" TextDocumentDidOpen params'
250 oldVFS <- vfs <$> get
251 newVFS <- liftIO $ openVFS oldVFS n
252 modify (\s -> s { vfs = newVFS })
255 -- | Close a virtual file if we send a close text document notification
256 sendNotification TextDocumentDidClose params = do
257 let params' = fromJust $ decode $ encode params
258 n :: DidCloseTextDocumentNotification
259 n = NotificationMessage "2.0" TextDocumentDidClose params'
260 oldVFS <- vfs <$> get
261 newVFS <- liftIO $ closeVFS oldVFS n
262 modify (\s -> s { vfs = newVFS })
265 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
267 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
268 sendNotification' = sendMessage
270 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
271 sendResponse = sendMessage
273 sendMessage :: ToJSON a => a -> Session ()
275 h <- serverIn <$> ask
276 liftIO $ B.hPut h $ addHeader (encode msg)
278 -- | Returns the initialize response that was received from the server.
279 -- The initialize requests and responses are not included the session,
280 -- so if you need to test it use this.
281 initializeResponse :: Session InitializeResponse
282 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
284 -- | Opens a text document and sends a notification to the client.
285 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
286 openDoc file languageId = do
287 item <- getDocItem file languageId
288 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
289 TextDocumentIdentifier <$> getDocUri file
291 -- | Reads in a text document as the first version.
292 getDocItem :: FilePath -- ^ The path to the text document to read in.
293 -> String -- ^ The language ID, e.g "haskell" for .hs files.
294 -> Session TextDocumentItem
295 getDocItem file languageId = do
297 let fp = rootDir context </> file
298 contents <- liftIO $ T.readFile fp
299 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
301 -- | Gets the Uri for the file corrected to the session directory.
302 getDocUri :: FilePath -> Session Uri
305 let fp = rootDir context </> file
306 return $ filePathToUri fp
308 getDiagnostics :: Session [Diagnostic]
310 diagsNot <- notification :: Session PublishDiagnosticsNotification
311 let (List diags) = diagsNot ^. params . LSP.diagnostics
314 -- | Expects a 'PublishDiagnosticsNotification' and throws an
315 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
317 noDiagnostics :: Session ()
319 diagsNot <- notification :: Session PublishDiagnosticsNotification
320 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
322 -- | Returns the symbols in a document.
323 getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
324 getDocumentSymbols doc = do
325 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)