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 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
224 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
225 sendNotification' = sendMessage
227 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
228 sendResponse = sendMessage
230 sendMessage :: ToJSON a => a -> Session ()
232 h <- serverIn <$> ask
233 liftIO $ B.hPut h $ addHeader (encode msg)
235 -- | Returns the initialize response that was received from the server.
236 -- The initialize requests and responses are not included the session,
237 -- so if you need to test it use this.
238 getInitializeResponse :: Session InitializeResponse
239 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
241 -- | Opens a text document and sends a notification to the client.
242 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
243 openDoc file languageId = do
244 item <- getDocItem file languageId
245 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
246 TextDocumentIdentifier <$> getDocUri file
248 -- | Reads in a text document as the first version.
249 getDocItem :: FilePath -- ^ The path to the text document to read in.
250 -> String -- ^ The language ID, e.g "haskell" for .hs files.
251 -> Session TextDocumentItem
252 getDocItem file languageId = do
254 let fp = rootDir context </> file
255 contents <- liftIO $ T.readFile fp
256 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
258 -- | Gets the Uri for the file corrected to the session directory.
259 getDocUri :: FilePath -> Session Uri
262 let fp = rootDir context </> file
263 return $ filePathToUri fp