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
34 , publishDiagnosticsNotification
57 , getInitializeResponse
64 import Control.Applicative
65 import Control.Applicative.Combinators
66 import Control.Monad.IO.Class
67 import Control.Concurrent
68 import Control.Lens hiding ((.=), List)
69 import qualified Data.Text as T
70 import qualified Data.Text.IO as T
72 import qualified Data.ByteString.Lazy.Char8 as B
74 import qualified Data.Map as Map
76 import Language.Haskell.LSP.Types
77 import qualified Language.Haskell.LSP.Types as LSP (error, id)
78 import Language.Haskell.LSP.VFS
79 import Language.Haskell.LSP.Test.Compat
80 import Language.Haskell.LSP.Test.Decoding
81 import Language.Haskell.LSP.Test.Parsing
82 import Language.Haskell.LSP.Test.Session
83 import Language.Haskell.LSP.Test.Server
85 import System.Directory
86 import System.FilePath
87 import qualified Yi.Rope as Rope
89 -- | Starts a new session.
90 runSession :: String -- ^ The command to run the server.
91 -> FilePath -- ^ The filepath to the root directory for the session.
92 -> Session a -- ^ The session to run.
94 runSession serverExe rootDir session = do
96 absRootDir <- canonicalizePath rootDir
98 let initializeParams = InitializeParams (Just pid)
99 (Just $ T.pack absRootDir)
100 (Just $ filePathToUri absRootDir)
105 withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
107 -- Wrap the session around initialize and shutdown calls
108 sendRequest Initialize initializeParams
109 initRspMsg <- response :: Session InitializeResponse
111 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
113 initRspVar <- initRsp <$> ask
114 liftIO $ putMVar initRspVar initRspMsg
116 sendNotification Initialized InitializedParams
118 -- Run the actual test
121 sendNotification Exit ExitParams
125 -- | Listens to the server output, makes sure it matches the record and
126 -- signals any semaphores
127 listenServer :: Handle -> Session ()
128 listenServer serverOut = do
129 msgBytes <- liftIO $ getNextMessage serverOut
132 reqMap <- liftIO $ readMVar $ requestMap context
134 let msg = decodeFromServerMsg reqMap msgBytes
135 liftIO $ writeChan (messageChan context) msg
137 listenServer serverOut
139 -- | The current text contents of a document.
140 documentContents :: TextDocumentIdentifier -> Session T.Text
141 documentContents doc = do
143 let file = vfs Map.! (doc ^. uri)
144 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
146 -- | Sends a request to the server.
149 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
150 -- TextDocumentDocumentSymbol
151 -- (DocumentSymbolParams docId)
155 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
156 ClientMethod -- ^ The request method.
157 -> params -- ^ The request parameters.
158 -> Session LspId -- ^ The id of the request that was sent.
159 sendRequest method params = do
160 id <- curReqId <$> get
161 modify $ \c -> c { curReqId = nextId id }
163 let req = RequestMessage' "2.0" id method params
165 -- Update the request map
166 reqMap <- requestMap <$> ask
167 liftIO $ modifyMVar_ reqMap $
168 \r -> return $ updateRequestMap r id method
174 where nextId (IdInt i) = IdInt (i + 1)
175 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
177 -- | A custom type for request message that doesn't
178 -- need a response type, allows us to infer the request
179 -- message type without using proxies.
180 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
182 instance ToJSON a => ToJSON (RequestMessage' a) where
183 toJSON (RequestMessage' rpc id method params) =
184 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
187 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
188 sendRequest' req = do
189 -- Update the request map
190 reqMap <- requestMap <$> ask
191 liftIO $ modifyMVar_ reqMap $
192 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
196 -- | Sends a notification to the server.
197 sendNotification :: ToJSON a
198 => ClientMethod -- ^ The notification method.
199 -> a -- ^ The notification parameters.
202 -- | Open a virtual file if we send a did open text document notification
203 sendNotification TextDocumentDidOpen params = do
204 let params' = fromJust $ decode $ encode params
205 n :: DidOpenTextDocumentNotification
206 n = NotificationMessage "2.0" TextDocumentDidOpen params'
207 oldVFS <- vfs <$> get
208 newVFS <- liftIO $ openVFS oldVFS n
209 modify (\s -> s { vfs = newVFS })
212 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
214 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
215 sendNotification' = sendMessage
217 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
218 sendResponse = sendMessage
220 sendMessage :: ToJSON a => a -> Session ()
222 h <- serverIn <$> ask
223 liftIO $ B.hPut h $ addHeader (encode msg)
225 -- | Returns the initialize response that was received from the server.
226 -- The initialize requests and responses are not included the session,
227 -- so if you need to test it use this.
228 getInitializeResponse :: Session InitializeResponse
229 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
231 -- | Opens a text document and sends a notification to the client.
232 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
233 openDoc file languageId = do
234 item <- getDocItem file languageId
235 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
236 TextDocumentIdentifier <$> getDocUri file
238 -- | Reads in a text document as the first version.
239 getDocItem :: FilePath -- ^ The path to the text document to read in.
240 -> String -- ^ The language ID, e.g "haskell" for .hs files.
241 -> Session TextDocumentItem
242 getDocItem file languageId = do
244 let fp = rootDir context </> file
245 contents <- liftIO $ T.readFile fp
246 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
248 -- | Gets the Uri for the file corrected to the session directory.
249 getDocUri :: FilePath -> Session Uri
252 let fp = rootDir context </> file
253 return $ filePathToUri fp