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 , runSessionWithHandler
68 import Control.Applicative
70 import Control.Monad.IO.Class
71 import Control.Concurrent
73 import qualified Data.Text as T
74 import qualified Data.Text.IO as T
76 import qualified Data.ByteString.Lazy.Char8 as B
80 import Language.Haskell.LSP.Types
81 import qualified Language.Haskell.LSP.Types as LSP (error)
82 import Language.Haskell.LSP.Messages
83 import Language.Haskell.LSP.Test.Compat
85 import System.Directory
86 import System.FilePath
87 import Language.Haskell.LSP.Test.Decoding
88 import Language.Haskell.LSP.Test.Parsing
89 import Text.Parser.Combinators
91 -- | Starts a new session.
92 runSession :: FilePath -- ^ The filepath to the root directory for the session.
93 -> Session a -- ^ The session to run.
95 runSession rootDir session = do
97 absRootDir <- canonicalizePath rootDir
99 let initializeParams = InitializeParams (Just pid)
100 (Just $ T.pack absRootDir)
101 (Just $ filePathToUri absRootDir)
106 runSessionWithHandler listenServer rootDir $ do
108 -- Wrap the session around initialize and shutdown calls
109 sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
110 RspInitialize initRsp <- response
111 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
113 sendNotification Initialized InitializedParams
115 -- Run the actual test
118 sendNotification Exit ExitParams
120 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
121 -- It also does not automatically send initialize and exit messages.
122 runSessionWithHandler :: (Handle -> Session ())
126 runSessionWithHandler serverHandler rootDir session = do
127 absRootDir <- canonicalizePath rootDir
129 (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
130 (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
131 { std_in = CreatePipe, std_out = CreatePipe }
133 hSetBuffering serverIn NoBuffering
134 hSetBuffering serverOut NoBuffering
136 reqMap <- newMVar newRequestMap
137 messageChan <- newChan
138 meaninglessChan <- newChan
140 let context = SessionContext serverIn absRootDir messageChan reqMap
141 initState = SessionState (IdInt 9)
143 forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
144 (result, _) <- runSession' messageChan context initState session
146 terminateProcess serverProc
150 -- | Listens to the server output, makes sure it matches the record and
151 -- signals any semaphores
152 listenServer :: Handle -> Session ()
153 listenServer serverOut = do
154 msgBytes <- liftIO $ getNextMessage serverOut
157 reqMap <- liftIO $ readMVar $ requestMap context
159 liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
161 listenServer serverOut
163 -- | Sends a request to the server.
166 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
167 -- TextDocumentDocumentSymbol
168 -- (DocumentSymbolParams docId)
171 :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
172 => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
173 -> ClientMethod -- ^ The request method.
174 -> params -- ^ The request parameters.
175 -> Session LspId -- ^ The id of the request that was sent.
176 sendRequest _ method params = do
177 id <- curReqId <$> get
178 modify $ \c -> c { curReqId = nextId id }
180 let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
186 where nextId (IdInt i) = IdInt (i + 1)
187 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
189 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
190 sendRequest' req = do
191 -- Update the request map
192 reqMap <- requestMap <$> ask
193 liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
197 -- | Sends a notification to the server.
198 sendNotification :: ToJSON a
199 => ClientMethod -- ^ The notification method.
200 -> a -- ^ The notification parameters.
202 sendNotification method params =
203 let notif = NotificationMessage "2.0" method params
204 in sendNotification' notif
206 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
207 sendNotification' = sendMessage
209 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
210 sendResponse = sendMessage
212 sendMessage :: ToJSON a => a -> Session ()
214 h <- serverIn <$> ask
215 liftIO $ B.hPut h $ addHeader (encode msg)
217 -- | Opens a text document and sends a notification to the client.
218 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
219 openDoc file languageId = do
220 item <- getDocItem file languageId
221 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
222 TextDocumentIdentifier <$> getDocUri file
224 -- | Reads in a text document as the first version.
225 getDocItem :: FilePath -- ^ The path to the text document to read in.
226 -> String -- ^ The language ID, e.g "haskell" for .hs files.
227 -> Session TextDocumentItem
228 getDocItem file languageId = do
230 let fp = rootDir context </> file
231 contents <- liftIO $ T.readFile fp
232 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
234 -- | Gets the Uri for the file corrected to the session directory.
235 getDocUri :: FilePath -> Session Uri
238 let fp = rootDir context </> file
239 return $ filePathToUri fp