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
63 import Control.Applicative
64 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
75 import qualified Data.HashMap.Strict as HashMap
77 import Language.Haskell.LSP.Types
78 import qualified Language.Haskell.LSP.Types as LSP (error, id)
79 import Language.Haskell.LSP.Messages
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
90 -- | Starts a new session.
91 runSession :: String -- ^ The command to run the server.
92 -> FilePath -- ^ The filepath to the root directory for the session.
93 -> Session a -- ^ The session to run.
95 runSession serverExe rootDir session = do
97 absRootDir <- canonicalizePath rootDir
99 let initializeParams = InitializeParams (Just pid)
100 (Just $ T.pack absRootDir)
101 (Just $ filePathToUri absRootDir)
106 withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
108 -- Wrap the session around initialize and shutdown calls
109 sendRequest Initialize initializeParams
110 initRspMsg <- response :: Session InitializeResponse
112 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
114 initRspVar <- initRsp <$> ask
115 liftIO $ putMVar initRspVar initRspMsg
117 sendNotification Initialized InitializedParams
119 -- Run the actual test
122 sendNotification Exit ExitParams
126 -- | Listens to the server output, makes sure it matches the record and
127 -- signals any semaphores
128 listenServer :: Handle -> Session ()
129 listenServer serverOut = do
130 msgBytes <- liftIO $ getNextMessage serverOut
133 reqMap <- liftIO $ readMVar $ requestMap context
135 let msg = decodeFromServerMsg reqMap msgBytes
136 processTextChanges msg
137 liftIO $ writeChan (messageChan context) msg
139 listenServer serverOut
141 processTextChanges :: FromServerMessage -> Session ()
142 processTextChanges (ReqApplyWorkspaceEdit r) = do
143 List changeParams <- case r ^. params . edit . documentChanges of
144 Just cs -> mapM applyTextDocumentEdit cs
145 Nothing -> case r ^. params . edit . changes of
146 Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
147 Nothing -> return (List [])
149 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
150 mergedParams = map mergeParams groupedParams
152 forM_ mergedParams (sendNotification TextDocumentDidChange)
154 where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
155 oldVFS <- vfs <$> get
156 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
157 params = DidChangeTextDocumentParams docId (List changeEvents)
158 newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
159 modify (\s -> s { vfs = newVFS })
160 liftIO $ print newVFS
163 applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
165 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
166 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
167 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
168 processTextChanges _ = return ()
170 -- | Sends a request to the server.
173 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
174 -- TextDocumentDocumentSymbol
175 -- (DocumentSymbolParams docId)
179 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
180 ClientMethod -- ^ The request method.
181 -> params -- ^ The request parameters.
182 -> Session LspId -- ^ The id of the request that was sent.
183 sendRequest method params = do
184 id <- curReqId <$> get
185 modify $ \c -> c { curReqId = nextId id }
187 let req = RequestMessage' "2.0" id method params
189 -- Update the request map
190 reqMap <- requestMap <$> ask
191 liftIO $ modifyMVar_ reqMap $
192 \r -> return $ updateRequestMap r id method
198 where nextId (IdInt i) = IdInt (i + 1)
199 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
201 -- | A custom type for request message that doesn't
202 -- need a response type, allows us to infer the request
203 -- message type without using proxies.
204 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
206 instance ToJSON a => ToJSON (RequestMessage' a) where
207 toJSON (RequestMessage' rpc id method params) =
208 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
211 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
212 sendRequest' req = do
213 -- Update the request map
214 reqMap <- requestMap <$> ask
215 liftIO $ modifyMVar_ reqMap $
216 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
220 -- | Sends a notification to the server.
221 sendNotification :: ToJSON a
222 => ClientMethod -- ^ The notification method.
223 -> a -- ^ The notification parameters.
225 sendNotification method params =
226 let notif = NotificationMessage "2.0" method params
227 in sendNotification' notif
229 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
230 sendNotification' = sendMessage
232 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
233 sendResponse = sendMessage
235 sendMessage :: ToJSON a => a -> Session ()
237 h <- serverIn <$> ask
238 liftIO $ B.hPut h $ addHeader (encode msg)
240 -- | Returns the initialize response that was received from the server.
241 -- The initialize requests and responses are not included the session,
242 -- so if you need to test it use this.
243 getInitializeResponse :: Session InitializeResponse
244 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
246 -- | Opens a text document and sends a notification to the client.
247 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
248 openDoc file languageId = do
249 item <- getDocItem file languageId
250 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
251 TextDocumentIdentifier <$> getDocUri file
253 -- | Reads in a text document as the first version.
254 getDocItem :: FilePath -- ^ The path to the text document to read in.
255 -> String -- ^ The language ID, e.g "haskell" for .hs files.
256 -> Session TextDocumentItem
257 getDocItem file languageId = do
259 let fp = rootDir context </> file
260 contents <- liftIO $ T.readFile fp
261 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
263 -- | Gets the Uri for the file corrected to the session directory.
264 getDocUri :: FilePath -> Session Uri
267 let fp = rootDir context </> file
268 return $ filePathToUri fp