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
67 import Control.Applicative
69 import Control.Monad.IO.Class
70 import Control.Concurrent
72 import qualified Data.Text as T
73 import qualified Data.Text.IO as T
75 import qualified Data.ByteString.Lazy.Char8 as B
79 import Language.Haskell.LSP.Types
80 import qualified Language.Haskell.LSP.Types as LSP (error)
81 import Language.Haskell.LSP.Messages
82 import Language.Haskell.LSP.Test.Compat
84 import System.Directory
85 import System.FilePath
86 import Language.Haskell.LSP.Test.Decoding
87 import Language.Haskell.LSP.Test.Parsing
88 import Text.Parser.Combinators
90 -- | Starts a new session.
91 runSession :: FilePath -- ^ The filepath to the root directory for the session.
92 -> Session a -- ^ The session to run.
94 runSession rootDir session = do
96 absRootDir <- canonicalizePath rootDir
98 let initializeParams = InitializeParams (Just pid)
99 (Just $ T.pack absRootDir)
100 (Just $ filePathToUri absRootDir)
105 runSessionWithHandler listenServer rootDir $ do
107 -- Wrap the session around initialize and shutdown calls
108 sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
109 RspInitialize initRsp <- response
110 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
112 sendNotification Initialized InitializedParams
114 -- Run the actual test
117 sendNotification Exit ExitParams
119 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
120 -- It also does not automatically send initialize and exit messages.
121 runSessionWithHandler :: (Handle -> Session ())
125 runSessionWithHandler serverHandler rootDir session = do
126 absRootDir <- canonicalizePath rootDir
128 (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
129 (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
130 { std_in = CreatePipe, std_out = CreatePipe }
132 hSetBuffering serverIn NoBuffering
133 hSetBuffering serverOut NoBuffering
135 reqMap <- newMVar newRequestMap
136 messageChan <- newChan
137 meaninglessChan <- newChan
139 let context = SessionContext serverIn absRootDir messageChan reqMap
140 initState = SessionState (IdInt 9)
142 forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
143 (result, _) <- runSession' messageChan context initState session
145 terminateProcess serverProc
149 -- | Listens to the server output, makes sure it matches the record and
150 -- signals any semaphores
151 listenServer :: Handle -> Session ()
152 listenServer serverOut = do
153 msgBytes <- liftIO $ getNextMessage serverOut
156 reqMap <- liftIO $ readMVar $ requestMap context
158 liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
160 listenServer serverOut
162 -- | Sends a request to the server.
165 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
166 -- TextDocumentDocumentSymbol
167 -- (DocumentSymbolParams docId)
170 :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
171 => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
172 -> ClientMethod -- ^ The request method.
173 -> params -- ^ The request parameters.
174 -> Session LspId -- ^ The id of the request that was sent.
175 sendRequest _ method params = do
176 id <- curReqId <$> get
177 modify $ \c -> c { curReqId = nextId id }
179 let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
185 where nextId (IdInt i) = IdInt (i + 1)
186 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
188 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
189 sendRequest' req = do
190 -- Update the request map
191 reqMap <- requestMap <$> ask
192 liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
196 -- | Sends a notification to the server.
197 sendNotification :: ToJSON a
198 => ClientMethod -- ^ The notification method.
199 -> a -- ^ The notification parameters.
201 sendNotification method params =
202 let notif = NotificationMessage "2.0" method params
203 in sendNotification' notif
205 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
206 sendNotification' = sendMessage
208 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
209 sendResponse = sendMessage
211 sendMessage :: ToJSON a => a -> Session ()
213 h <- serverIn <$> ask
214 liftIO $ B.hPut h $ addHeader (encode msg)
216 -- | Reads in a text document as the first version.
217 getDocItem :: FilePath -- ^ The path to the text document to read in.
218 -> String -- ^ The language ID, e.g "haskell" for .hs files.
219 -> Session TextDocumentItem
220 getDocItem file languageId = do
222 let fp = rootDir context </> file
223 contents <- liftIO $ T.readFile fp
224 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
226 -- | Gets the Uri for the file corrected to the session directory.
227 getDocUri :: FilePath -> Session Uri
230 let fp = rootDir context </> file
231 return $ filePathToUri fp