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
31 , publishDiagnosticsNotification
59 import Control.Applicative
60 import Control.Applicative.Combinators
62 import Control.Monad.IO.Class
63 import Control.Concurrent
65 import qualified Data.Text as T
66 import qualified Data.Text.IO as T
68 import qualified Data.ByteString.Lazy.Char8 as B
72 import Language.Haskell.LSP.Types
73 import qualified Language.Haskell.LSP.Types as LSP (error)
74 import Language.Haskell.LSP.Messages
75 import Language.Haskell.LSP.Test.Compat
77 import System.Directory
78 import System.FilePath
79 import Language.Haskell.LSP.Test.Decoding
80 import Language.Haskell.LSP.Test.Parsing
82 -- | Starts a new session.
83 runSession :: FilePath -- ^ The filepath to the root directory for the session.
84 -> Session a -- ^ The session to run.
86 runSession rootDir session = do
88 absRootDir <- canonicalizePath rootDir
90 let initializeParams = InitializeParams (Just pid)
91 (Just $ T.pack absRootDir)
92 (Just $ filePathToUri absRootDir)
97 runSessionWithHandler listenServer rootDir $ do
99 -- Wrap the session around initialize and shutdown calls
100 sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
101 RspInitialize initRsp <- response
102 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
104 sendNotification Initialized InitializedParams
106 -- Run the actual test
109 sendNotification Exit ExitParams
111 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
112 -- It also does not automatically send initialize and exit messages.
113 runSessionWithHandler :: (Handle -> Session ())
117 runSessionWithHandler serverHandler rootDir session = do
118 absRootDir <- canonicalizePath rootDir
120 (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
121 (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
122 { std_in = CreatePipe, std_out = CreatePipe }
124 hSetBuffering serverIn NoBuffering
125 hSetBuffering serverOut NoBuffering
127 reqMap <- newMVar newRequestMap
128 messageChan <- newChan
129 meaninglessChan <- newChan
131 let context = SessionContext serverIn absRootDir messageChan reqMap
132 initState = SessionState (IdInt 9)
134 forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
135 (result, _) <- runSession' messageChan context initState session
137 terminateProcess serverProc
141 -- | Listens to the server output, makes sure it matches the record and
142 -- signals any semaphores
143 listenServer :: Handle -> Session ()
144 listenServer serverOut = do
145 msgBytes <- liftIO $ getNextMessage serverOut
148 reqMap <- liftIO $ readMVar $ requestMap context
150 liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
152 listenServer serverOut
154 -- | Sends a request to the server.
157 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
158 -- TextDocumentDocumentSymbol
159 -- (DocumentSymbolParams docId)
162 :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
163 => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
164 -> ClientMethod -- ^ The request method.
165 -> params -- ^ The request parameters.
166 -> Session LspId -- ^ The id of the request that was sent.
167 sendRequest _ method params = do
168 id <- curReqId <$> get
169 modify $ \c -> c { curReqId = nextId id }
171 let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
177 where nextId (IdInt i) = IdInt (i + 1)
178 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
180 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
181 sendRequest' req = do
182 -- Update the request map
183 reqMap <- requestMap <$> ask
184 liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
188 -- | Sends a notification to the server.
189 sendNotification :: ToJSON a
190 => ClientMethod -- ^ The notification method.
191 -> a -- ^ The notification parameters.
193 sendNotification method params =
194 let notif = NotificationMessage "2.0" method params
195 in sendNotification' notif
197 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
198 sendNotification' = sendMessage
200 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
201 sendResponse = sendMessage
203 sendMessage :: ToJSON a => a -> Session ()
205 h <- serverIn <$> ask
206 liftIO $ B.hPut h $ addHeader (encode msg)
208 -- | Opens a text document and sends a notification to the client.
209 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
210 openDoc file languageId = do
211 item <- getDocItem file languageId
212 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
213 TextDocumentIdentifier <$> getDocUri file
215 -- | Reads in a text document as the first version.
216 getDocItem :: FilePath -- ^ The path to the text document to read in.
217 -> String -- ^ The language ID, e.g "haskell" for .hs files.
218 -> Session TextDocumentItem
219 getDocItem file languageId = do
221 let fp = rootDir context </> file
222 contents <- liftIO $ T.readFile fp
223 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
225 -- | Gets the Uri for the file corrected to the session directory.
226 getDocUri :: FilePath -> Session Uri
229 let fp = rootDir context </> file
230 return $ filePathToUri fp