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
62 , getInitializeResponse
69 import Control.Applicative
70 import Control.Applicative.Combinators
71 import Control.Monad.IO.Class
72 import Control.Concurrent
73 import Control.Lens hiding ((.=), List)
74 import qualified Data.Text as T
75 import qualified Data.Text.IO as T
77 import qualified Data.ByteString.Lazy.Char8 as B
79 import qualified Data.Map as Map
81 import Language.Haskell.LSP.Types hiding (id, capabilities)
82 import qualified Language.Haskell.LSP.Types as LSP
83 import Language.Haskell.LSP.VFS
84 import Language.Haskell.LSP.Test.Compat
85 import Language.Haskell.LSP.Test.Decoding
86 import Language.Haskell.LSP.Test.Exceptions
87 import Language.Haskell.LSP.Test.Parsing
88 import Language.Haskell.LSP.Test.Session
89 import Language.Haskell.LSP.Test.Server
91 import System.Directory
92 import System.FilePath
93 import qualified Yi.Rope as Rope
95 -- | Starts a new session.
96 runSession :: String -- ^ The command to run the server.
97 -> FilePath -- ^ The filepath to the root directory for the session.
98 -> Session a -- ^ The session to run.
100 runSession = runSessionWithConfig def
102 -- | Starts a new sesion with a client with the specified capabilities.
103 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
104 -> String -- ^ The command to run the server.
105 -> FilePath -- ^ The filepath to the root directory for the session.
106 -> Session a -- ^ The session to run.
108 runSessionWithConfig config serverExe rootDir session = do
109 pid <- getCurrentProcessID
110 absRootDir <- canonicalizePath rootDir
112 let initializeParams = InitializeParams (Just pid)
113 (Just $ T.pack absRootDir)
114 (Just $ filePathToUri absRootDir)
116 (capabilities config)
119 withServer serverExe $ \serverIn serverOut _ ->
120 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
122 -- Wrap the session around initialize and shutdown calls
123 sendRequest Initialize initializeParams
124 initRspMsg <- response :: Session InitializeResponse
126 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
128 initRspVar <- initRsp <$> ask
129 liftIO $ putMVar initRspVar initRspMsg
131 sendNotification Initialized InitializedParams
133 -- Run the actual test
136 sendNotification Exit ExitParams
140 -- | Listens to the server output, makes sure it matches the record and
141 -- signals any semaphores
142 listenServer :: Handle -> Session ()
143 listenServer serverOut = do
144 msgBytes <- liftIO $ getNextMessage serverOut
147 reqMap <- liftIO $ readMVar $ requestMap context
149 let msg = decodeFromServerMsg reqMap msgBytes
150 liftIO $ writeChan (messageChan context) msg
152 listenServer serverOut
154 -- | The current text contents of a document.
155 documentContents :: TextDocumentIdentifier -> Session T.Text
156 documentContents doc = do
158 let file = vfs Map.! (doc ^. uri)
159 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
161 -- | Sends a request to the server.
164 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
165 -- TextDocumentDocumentSymbol
166 -- (DocumentSymbolParams docId)
170 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
171 ClientMethod -- ^ The request method.
172 -> params -- ^ The request parameters.
173 -> Session LspId -- ^ The id of the request that was sent.
174 sendRequest method params = do
175 id <- curReqId <$> get
176 modify $ \c -> c { curReqId = nextId id }
178 let req = RequestMessage' "2.0" id method params
180 -- Update the request map
181 reqMap <- requestMap <$> ask
182 liftIO $ modifyMVar_ reqMap $
183 \r -> return $ updateRequestMap r id method
189 where nextId (IdInt i) = IdInt (i + 1)
190 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
192 -- | A custom type for request message that doesn't
193 -- need a response type, allows us to infer the request
194 -- message type without using proxies.
195 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
197 instance ToJSON a => ToJSON (RequestMessage' a) where
198 toJSON (RequestMessage' rpc id method params) =
199 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
202 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
203 sendRequest' req = do
204 -- Update the request map
205 reqMap <- requestMap <$> ask
206 liftIO $ modifyMVar_ reqMap $
207 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
211 -- | Sends a notification to the server.
212 sendNotification :: ToJSON a
213 => ClientMethod -- ^ The notification method.
214 -> a -- ^ The notification parameters.
217 -- | Open a virtual file if we send a did open text document notification
218 sendNotification TextDocumentDidOpen params = do
219 let params' = fromJust $ decode $ encode params
220 n :: DidOpenTextDocumentNotification
221 n = NotificationMessage "2.0" TextDocumentDidOpen params'
222 oldVFS <- vfs <$> get
223 newVFS <- liftIO $ openVFS oldVFS n
224 modify (\s -> s { vfs = newVFS })
227 -- | Close a virtual file if we send a close text document notification
228 sendNotification TextDocumentDidClose params = do
229 let params' = fromJust $ decode $ encode params
230 n :: DidCloseTextDocumentNotification
231 n = NotificationMessage "2.0" TextDocumentDidClose params'
232 oldVFS <- vfs <$> get
233 newVFS <- liftIO $ closeVFS oldVFS n
234 modify (\s -> s { vfs = newVFS })
237 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
239 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
240 sendNotification' = sendMessage
242 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
243 sendResponse = sendMessage
245 sendMessage :: ToJSON a => a -> Session ()
247 h <- serverIn <$> ask
248 liftIO $ B.hPut h $ addHeader (encode msg)
250 -- | Returns the initialize response that was received from the server.
251 -- The initialize requests and responses are not included the session,
252 -- so if you need to test it use this.
253 getInitializeResponse :: Session InitializeResponse
254 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
256 -- | Opens a text document and sends a notification to the client.
257 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
258 openDoc file languageId = do
259 item <- getDocItem file languageId
260 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
261 TextDocumentIdentifier <$> getDocUri file
263 -- | Reads in a text document as the first version.
264 getDocItem :: FilePath -- ^ The path to the text document to read in.
265 -> String -- ^ The language ID, e.g "haskell" for .hs files.
266 -> Session TextDocumentItem
267 getDocItem file languageId = do
269 let fp = rootDir context </> file
270 contents <- liftIO $ T.readFile fp
271 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
273 -- | Gets the Uri for the file corrected to the session directory.
274 getDocUri :: FilePath -> Session Uri
277 let fp = rootDir context </> file
278 return $ filePathToUri fp