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
34 , publishDiagnosticsNotification
62 import Control.Applicative
63 import Control.Applicative.Combinators
65 import Control.Monad.IO.Class
66 import Control.Concurrent
67 import Control.Lens hiding ((.=))
68 import qualified Data.Text as T
69 import qualified Data.Text.IO as T
71 import qualified Data.ByteString.Lazy.Char8 as B
74 import Language.Haskell.LSP.Types
75 import qualified Language.Haskell.LSP.Types as LSP (error, id)
76 import Language.Haskell.LSP.Test.Compat
78 import System.Directory
79 import System.FilePath
80 import Language.Haskell.LSP.Test.Decoding
81 import Language.Haskell.LSP.Test.Parsing
83 -- | Starts a new session.
84 runSession :: FilePath -- ^ The filepath to the server executable.
85 -> FilePath -- ^ The filepath to the root directory for the session.
86 -> Session a -- ^ The session to run.
88 runSession serverExe rootDir session = do
90 absRootDir <- canonicalizePath rootDir
92 let initializeParams = InitializeParams (Just pid)
93 (Just $ T.pack absRootDir)
94 (Just $ filePathToUri absRootDir)
99 runSessionWithHandler listenServer serverExe rootDir $ do
101 -- Wrap the session around initialize and shutdown calls
102 sendRequest Initialize initializeParams
103 initRsp <- response :: Session InitializeResponse
104 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
106 sendNotification Initialized InitializedParams
108 -- Run the actual test
111 sendNotification Exit ExitParams
113 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
114 -- It also does not automatically send initialize and exit messages.
115 runSessionWithHandler :: (Handle -> Session ())
120 runSessionWithHandler serverHandler serverExe rootDir session = do
121 absRootDir <- canonicalizePath rootDir
123 (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
124 (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
125 { std_in = CreatePipe, std_out = CreatePipe }
127 hSetBuffering serverIn NoBuffering
128 hSetBuffering serverOut NoBuffering
130 reqMap <- newMVar newRequestMap
131 messageChan <- newChan
132 meaninglessChan <- newChan
134 let context = SessionContext serverIn absRootDir messageChan reqMap
135 initState = SessionState (IdInt 9)
137 threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
138 (result, _) <- runSession' messageChan context initState session
140 terminateProcess serverProc
145 -- | Listens to the server output, makes sure it matches the record and
146 -- signals any semaphores
147 listenServer :: Handle -> Session ()
148 listenServer serverOut = do
149 msgBytes <- liftIO $ getNextMessage serverOut
152 reqMap <- liftIO $ readMVar $ requestMap context
154 liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
156 listenServer serverOut
158 -- | Sends a request to the server.
161 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
162 -- TextDocumentDocumentSymbol
163 -- (DocumentSymbolParams docId)
167 => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
168 ClientMethod -- ^ The request method.
169 -> params -- ^ The request parameters.
170 -> Session LspId -- ^ The id of the request that was sent.
171 sendRequest method params = do
172 id <- curReqId <$> get
173 modify $ \c -> c { curReqId = nextId id }
175 let req = RequestMessage' "2.0" id method params
177 -- Update the request map
178 reqMap <- requestMap <$> ask
179 liftIO $ modifyMVar_ reqMap $
180 \r -> return $ updateRequestMap r id method
186 where nextId (IdInt i) = IdInt (i + 1)
187 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
189 -- | A custom type for request message that doesn't
190 -- need a response type, allows us to infer the request
191 -- message type without using proxies.
192 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
194 instance ToJSON a => ToJSON (RequestMessage' a) where
195 toJSON (RequestMessage' rpc id method params) =
196 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
199 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
200 sendRequest' req = do
201 -- Update the request map
202 reqMap <- requestMap <$> ask
203 liftIO $ modifyMVar_ reqMap $
204 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
208 -- | Sends a notification to the server.
209 sendNotification :: ToJSON a
210 => ClientMethod -- ^ The notification method.
211 -> a -- ^ The notification parameters.
213 sendNotification method params =
214 let notif = NotificationMessage "2.0" method params
215 in sendNotification' notif
217 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
218 sendNotification' = sendMessage
220 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
221 sendResponse = sendMessage
223 sendMessage :: ToJSON a => a -> Session ()
225 h <- serverIn <$> ask
226 liftIO $ B.hPut h $ addHeader (encode msg)
228 -- | Opens a text document and sends a notification to the client.
229 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
230 openDoc file languageId = do
231 item <- getDocItem file languageId
232 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
233 TextDocumentIdentifier <$> getDocUri file
235 -- | Reads in a text document as the first version.
236 getDocItem :: FilePath -- ^ The path to the text document to read in.
237 -> String -- ^ The language ID, e.g "haskell" for .hs files.
238 -> Session TextDocumentItem
239 getDocItem file languageId = do
241 let fp = rootDir context </> file
242 contents <- liftIO $ T.readFile fp
243 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
245 -- | Gets the Uri for the file corrected to the session directory.
246 getDocUri :: FilePath -> Session Uri
249 let fp = rootDir context </> file
250 return $ filePathToUri fp