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 , runSessionWithCapabilities
35 , publishDiagnosticsNotification
58 , getInitializeResponse
65 import Control.Applicative
66 import Control.Applicative.Combinators
67 import Control.Monad.IO.Class
68 import Control.Concurrent
69 import Control.Lens hiding ((.=), List)
70 import qualified Data.Text as T
71 import qualified Data.Text.IO as T
73 import qualified Data.ByteString.Lazy.Char8 as B
75 import qualified Data.Map as Map
77 import Language.Haskell.LSP.Types
78 import qualified Language.Haskell.LSP.Types as LSP (error, id)
79 import Language.Haskell.LSP.TH.ClientCapabilities
80 import Language.Haskell.LSP.VFS
81 import Language.Haskell.LSP.Test.Compat
82 import Language.Haskell.LSP.Test.Decoding
83 import Language.Haskell.LSP.Test.Parsing
84 import Language.Haskell.LSP.Test.Session
85 import Language.Haskell.LSP.Test.Server
87 import System.Directory
88 import System.FilePath
89 import qualified Yi.Rope as Rope
91 -- | Starts a new session.
92 runSession :: String -- ^ The command to run the server.
93 -> FilePath -- ^ The filepath to the root directory for the session.
94 -> Session a -- ^ The session to run.
96 runSession = runSessionWithCapabilities def
98 -- | Starts a new sesion with a client with the specified capabilities.
99 runSessionWithCapabilities :: ClientCapabilities -- ^ The capabilities the client should have.
100 -> String -- ^ The command to run the server.
101 -> FilePath -- ^ The filepath to the root directory for the session.
102 -> Session a -- ^ The session to run.
104 runSessionWithCapabilities caps serverExe rootDir session = do
106 absRootDir <- canonicalizePath rootDir
108 let initializeParams = InitializeParams (Just pid)
109 (Just $ T.pack absRootDir)
110 (Just $ filePathToUri absRootDir)
115 withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
117 -- Wrap the session around initialize and shutdown calls
118 sendRequest Initialize initializeParams
119 initRspMsg <- response :: Session InitializeResponse
121 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
123 initRspVar <- initRsp <$> ask
124 liftIO $ putMVar initRspVar initRspMsg
126 sendNotification Initialized InitializedParams
128 -- Run the actual test
131 sendNotification Exit ExitParams
135 -- | Listens to the server output, makes sure it matches the record and
136 -- signals any semaphores
137 listenServer :: Handle -> Session ()
138 listenServer serverOut = do
139 msgBytes <- liftIO $ getNextMessage serverOut
142 reqMap <- liftIO $ readMVar $ requestMap context
144 let msg = decodeFromServerMsg reqMap msgBytes
145 liftIO $ writeChan (messageChan context) msg
147 listenServer serverOut
149 -- | The current text contents of a document.
150 documentContents :: TextDocumentIdentifier -> Session T.Text
151 documentContents doc = do
153 let file = vfs Map.! (doc ^. uri)
154 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
156 -- | Sends a request to the server.
159 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
160 -- TextDocumentDocumentSymbol
161 -- (DocumentSymbolParams docId)
165 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
166 ClientMethod -- ^ The request method.
167 -> params -- ^ The request parameters.
168 -> Session LspId -- ^ The id of the request that was sent.
169 sendRequest method params = do
170 id <- curReqId <$> get
171 modify $ \c -> c { curReqId = nextId id }
173 let req = RequestMessage' "2.0" id method params
175 -- Update the request map
176 reqMap <- requestMap <$> ask
177 liftIO $ modifyMVar_ reqMap $
178 \r -> return $ updateRequestMap r id method
184 where nextId (IdInt i) = IdInt (i + 1)
185 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
187 -- | A custom type for request message that doesn't
188 -- need a response type, allows us to infer the request
189 -- message type without using proxies.
190 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
192 instance ToJSON a => ToJSON (RequestMessage' a) where
193 toJSON (RequestMessage' rpc id method params) =
194 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
197 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
198 sendRequest' req = do
199 -- Update the request map
200 reqMap <- requestMap <$> ask
201 liftIO $ modifyMVar_ reqMap $
202 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
206 -- | Sends a notification to the server.
207 sendNotification :: ToJSON a
208 => ClientMethod -- ^ The notification method.
209 -> a -- ^ The notification parameters.
212 -- | Open a virtual file if we send a did open text document notification
213 sendNotification TextDocumentDidOpen params = do
214 let params' = fromJust $ decode $ encode params
215 n :: DidOpenTextDocumentNotification
216 n = NotificationMessage "2.0" TextDocumentDidOpen params'
217 oldVFS <- vfs <$> get
218 newVFS <- liftIO $ openVFS oldVFS n
219 modify (\s -> s { vfs = newVFS })
222 -- | Close a virtual file if we send a close text document notification
223 sendNotification TextDocumentDidClose params = do
224 let params' = fromJust $ decode $ encode params
225 n :: DidCloseTextDocumentNotification
226 n = NotificationMessage "2.0" TextDocumentDidClose params'
227 oldVFS <- vfs <$> get
228 newVFS <- liftIO $ closeVFS oldVFS n
229 modify (\s -> s { vfs = newVFS })
232 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
234 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
235 sendNotification' = sendMessage
237 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
238 sendResponse = sendMessage
240 sendMessage :: ToJSON a => a -> Session ()
242 h <- serverIn <$> ask
243 liftIO $ B.hPut h $ addHeader (encode msg)
245 -- | Returns the initialize response that was received from the server.
246 -- The initialize requests and responses are not included the session,
247 -- so if you need to test it use this.
248 getInitializeResponse :: Session InitializeResponse
249 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
251 -- | Opens a text document and sends a notification to the client.
252 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
253 openDoc file languageId = do
254 item <- getDocItem file languageId
255 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
256 TextDocumentIdentifier <$> getDocUri file
258 -- | Reads in a text document as the first version.
259 getDocItem :: FilePath -- ^ The path to the text document to read in.
260 -> String -- ^ The language ID, e.g "haskell" for .hs files.
261 -> Session TextDocumentItem
262 getDocItem file languageId = do
264 let fp = rootDir context </> file
265 contents <- liftIO $ T.readFile fp
266 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
268 -- | Gets the Uri for the file corrected to the session directory.
269 getDocUri :: FilePath -> Session Uri
272 let fp = rootDir context </> file
273 return $ filePathToUri fp