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
64 import Control.Applicative
65 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
76 import qualified Data.HashMap.Strict as HashMap
78 import Language.Haskell.LSP.Types
79 import qualified Language.Haskell.LSP.Types as LSP (error, id)
80 import Language.Haskell.LSP.TH.ClientCapabilities
81 import Language.Haskell.LSP.Messages
82 import Language.Haskell.LSP.VFS
83 import Language.Haskell.LSP.Test.Compat
84 import Language.Haskell.LSP.Test.Decoding
85 import Language.Haskell.LSP.Test.Parsing
86 import Language.Haskell.LSP.Test.Session
87 import Language.Haskell.LSP.Test.Server
89 import System.Directory
90 import System.FilePath
92 -- | Starts a new session.
93 runSession :: String -- ^ The command to run the server.
94 -> FilePath -- ^ The filepath to the root directory for the session.
95 -> Session a -- ^ The session to run.
97 runSession = runSessionWithCapabilities def
99 -- | Starts a new sesion with a client with the specified capabilities.
100 runSessionWithCapabilities :: ClientCapabilities -- ^ The capabilities the client should have.
101 -> String -- ^ The command to run the server.
102 -> FilePath -- ^ The filepath to the root directory for the session.
103 -> Session a -- ^ The session to run.
105 runSessionWithCapabilities caps serverExe rootDir session = do
107 absRootDir <- canonicalizePath rootDir
109 let initializeParams = InitializeParams (Just pid)
110 (Just $ T.pack absRootDir)
111 (Just $ filePathToUri absRootDir)
116 withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
118 -- Wrap the session around initialize and shutdown calls
119 sendRequest Initialize initializeParams
120 initRspMsg <- response :: Session InitializeResponse
122 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
124 initRspVar <- initRsp <$> ask
125 liftIO $ putMVar initRspVar initRspMsg
127 sendNotification Initialized InitializedParams
129 -- Run the actual test
132 sendNotification Exit ExitParams
136 -- | Listens to the server output, makes sure it matches the record and
137 -- signals any semaphores
138 listenServer :: Handle -> Session ()
139 listenServer serverOut = do
140 msgBytes <- liftIO $ getNextMessage serverOut
143 reqMap <- liftIO $ readMVar $ requestMap context
145 let msg = decodeFromServerMsg reqMap msgBytes
146 processTextChanges msg
147 liftIO $ writeChan (messageChan context) msg
149 listenServer serverOut
151 processTextChanges :: FromServerMessage -> Session ()
152 processTextChanges (ReqApplyWorkspaceEdit r) = do
153 List changeParams <- case r ^. params . edit . documentChanges of
154 Just cs -> mapM applyTextDocumentEdit cs
155 Nothing -> case r ^. params . edit . changes of
156 Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
157 Nothing -> return (List [])
159 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
160 mergedParams = map mergeParams groupedParams
162 forM_ mergedParams (sendNotification TextDocumentDidChange)
164 where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
165 oldVFS <- vfs <$> get
166 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
167 params = DidChangeTextDocumentParams docId (List changeEvents)
168 newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
169 modify (\s -> s { vfs = newVFS })
172 applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
174 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
175 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
176 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
177 processTextChanges _ = return ()
179 -- | Sends a request to the server.
182 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
183 -- TextDocumentDocumentSymbol
184 -- (DocumentSymbolParams docId)
188 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
189 ClientMethod -- ^ The request method.
190 -> params -- ^ The request parameters.
191 -> Session LspId -- ^ The id of the request that was sent.
192 sendRequest method params = do
193 id <- curReqId <$> get
194 modify $ \c -> c { curReqId = nextId id }
196 let req = RequestMessage' "2.0" id method params
198 -- Update the request map
199 reqMap <- requestMap <$> ask
200 liftIO $ modifyMVar_ reqMap $
201 \r -> return $ updateRequestMap r id method
207 where nextId (IdInt i) = IdInt (i + 1)
208 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
210 -- | A custom type for request message that doesn't
211 -- need a response type, allows us to infer the request
212 -- message type without using proxies.
213 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
215 instance ToJSON a => ToJSON (RequestMessage' a) where
216 toJSON (RequestMessage' rpc id method params) =
217 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
220 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
221 sendRequest' req = do
222 -- Update the request map
223 reqMap <- requestMap <$> ask
224 liftIO $ modifyMVar_ reqMap $
225 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
229 -- | Sends a notification to the server.
230 sendNotification :: ToJSON a
231 => ClientMethod -- ^ The notification method.
232 -> a -- ^ The notification parameters.
234 sendNotification method params =
235 let notif = NotificationMessage "2.0" method params
236 in sendNotification' notif
238 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
239 sendNotification' = sendMessage
241 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
242 sendResponse = sendMessage
244 sendMessage :: ToJSON a => a -> Session ()
246 h <- serverIn <$> ask
247 liftIO $ B.hPut h $ addHeader (encode msg)
249 -- | Returns the initialize response that was received from the server.
250 -- The initialize requests and responses are not included the session,
251 -- so if you need to test it use this.
252 getInitializeResponse :: Session InitializeResponse
253 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
255 -- | Opens a text document and sends a notification to the client.
256 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
257 openDoc file languageId = do
258 item <- getDocItem file languageId
259 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
260 TextDocumentIdentifier <$> getDocUri file
262 -- | Reads in a text document as the first version.
263 getDocItem :: FilePath -- ^ The path to the text document to read in.
264 -> String -- ^ The language ID, e.g "haskell" for .hs files.
265 -> Session TextDocumentItem
266 getDocItem file languageId = do
268 let fp = rootDir context </> file
269 contents <- liftIO $ T.readFile fp
270 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
272 -- | Gets the Uri for the file corrected to the session directory.
273 getDocUri :: FilePath -> Session Uri
276 let fp = rootDir context </> file
277 return $ filePathToUri fp