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)
125 withServer serverExe $ \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 documentEdit :: TextDocumentIdentifier -> Session T.Text
170 documentEdit 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 liftIO $ B.hPut h $ addHeader (encode msg)
279 -- | Returns the initialize response that was received from the server.
280 -- The initialize requests and responses are not included the session,
281 -- so if you need to test it use this.
282 initializeResponse :: Session InitializeResponse
283 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
285 -- | Opens a text document and sends a notification to the client.
286 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
287 openDoc file languageId = do
288 item <- getDocItem file languageId
289 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
290 TextDocumentIdentifier <$> getDocUri file
292 -- | Reads in a text document as the first version.
293 getDocItem :: FilePath -- ^ The path to the text document to read in.
294 -> String -- ^ The language ID, e.g "haskell" for .hs files.
295 -> Session TextDocumentItem
296 getDocItem file languageId = do
298 let fp = rootDir context </> file
299 contents <- liftIO $ T.readFile fp
300 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
302 -- | Gets the Uri for the file corrected to the session directory.
303 getDocUri :: FilePath -> Session Uri
306 let fp = rootDir context </> file
307 return $ filePathToUri fp
309 -- | Expects a 'PublishDiagnosticsNotification' and throws an
310 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
312 noDiagnostics :: Session ()
314 diagsNot <- notification :: Session PublishDiagnosticsNotification
315 when (diagsNot ^. params . diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
317 -- | Returns the symbols in a document.
318 documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
319 documentSymbols doc = do
320 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)