2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE RankNTypes #-}
8 module Language.Haskell.LSP.Test.Session
15 , runSessionWithHandles
31 import Control.Concurrent hiding (yield)
32 import Control.Exception
33 import Control.Lens hiding (List)
35 import Control.Monad.IO.Class
36 import Control.Monad.Except
37 #if __GLASGOW_HASKELL__ >= 806
38 import Control.Monad.Fail
40 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
41 import qualified Control.Monad.Trans.Reader as Reader (ask)
42 import Control.Monad.Trans.State (StateT, runStateT)
43 import qualified Control.Monad.Trans.State as State (get, put)
44 import qualified Data.ByteString.Lazy.Char8 as B
46 import Data.Aeson.Encode.Pretty
47 import Data.Conduit as Conduit
48 import Data.Conduit.Parser as Parser
52 import qualified Data.Map as Map
53 import qualified Data.Text as T
54 import qualified Data.Text.IO as T
55 import qualified Data.HashMap.Strict as HashMap
58 import Language.Haskell.LSP.Messages
59 import Language.Haskell.LSP.Types.Capabilities
60 import Language.Haskell.LSP.Types
61 import Language.Haskell.LSP.Types.Lens hiding (error)
62 import Language.Haskell.LSP.VFS
63 import Language.Haskell.LSP.Test.Decoding
64 import Language.Haskell.LSP.Test.Exceptions
65 import System.Console.ANSI
66 import System.Directory
69 -- | A session representing one instance of launching and connecting to a server.
71 -- You can send and receive messages to the server within 'Session' via
72 -- 'Language.Haskell.LSP.Test.message',
73 -- 'Language.Haskell.LSP.Test.sendRequest' and
74 -- 'Language.Haskell.LSP.Test.sendNotification'.
76 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
78 #if __GLASGOW_HASKELL__ >= 806
79 instance MonadFail Session where
81 lastMsg <- fromJust . lastReceivedMessage <$> get
82 liftIO $ throw (UnexpectedMessage s lastMsg)
85 -- | Stuff you can configure for a 'Session'.
86 data SessionConfig = SessionConfig
87 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
88 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
89 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False.
90 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
91 , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
94 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
95 defaultConfig :: SessionConfig
96 defaultConfig = SessionConfig 60 False False True Nothing
98 instance Default SessionConfig where
101 data SessionMessage = ServerMessage FromServerMessage
105 data SessionContext = SessionContext
108 , rootDir :: FilePath
109 , messageChan :: Chan SessionMessage
110 , requestMap :: MVar RequestMap
111 , initRsp :: MVar InitializeResponse
112 , config :: SessionConfig
113 , sessionCapabilities :: ClientCapabilities
116 class Monad m => HasReader r m where
118 asks :: (r -> b) -> m b
121 instance Monad m => HasReader r (ParserStateReader a s r m) where
122 ask = lift $ lift Reader.ask
124 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
125 ask = lift $ lift Reader.ask
127 data SessionState = SessionState
131 , curDiagnostics :: Map.Map Uri [Diagnostic]
132 , curTimeoutId :: Int
133 , overridingTimeout :: Bool
134 -- ^ The last received message from the server.
135 -- Used for providing exception information
136 , lastReceivedMessage :: Maybe FromServerMessage
139 class Monad m => HasState s m where
144 modify :: (s -> s) -> m ()
145 modify f = get >>= put . f
147 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
148 modifyM f = get >>= f >>= put
150 instance Monad m => HasState s (ParserStateReader a s r m) where
152 put = lift . State.put
154 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
157 put = lift . State.put
159 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
161 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
162 runSession context state session = runReaderT (runStateT conduit state) context
164 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
166 handler (Unexpected "ConduitParser.empty") = do
167 lastMsg <- fromJust . lastReceivedMessage <$> get
168 name <- getParserName
169 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
174 msg <- liftIO $ readChan (messageChan context)
178 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
179 watchdog = Conduit.awaitForever $ \msg -> do
180 curId <- curTimeoutId <$> get
182 ServerMessage sMsg -> yield sMsg
183 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
185 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
186 -- It also does not automatically send initialize and exit messages.
187 runSessionWithHandles :: Handle -- ^ Server in
188 -> Handle -- ^ Server out
189 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
191 -> ClientCapabilities
192 -> FilePath -- ^ Root directory
195 runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
196 absRootDir <- canonicalizePath rootDir
198 hSetBuffering serverIn NoBuffering
199 hSetBuffering serverOut NoBuffering
200 -- This is required to make sure that we don’t get any
201 -- newline conversion or weird encoding issues.
202 hSetBinaryMode serverIn True
203 hSetBinaryMode serverOut True
205 reqMap <- newMVar newRequestMap
206 messageChan <- newChan
207 initRsp <- newEmptyMVar
209 mainThreadId <- myThreadId
211 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
212 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
213 launchServerHandler = forkIO $ catch (serverHandler serverOut context)
214 (throwTo mainThreadId :: SessionException -> IO ())
215 (result, _) <- bracket launchServerHandler killThread $
216 const $ runSession context initState session
220 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
221 updateStateC = awaitForever $ \msg -> do
225 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
226 updateState (NotPublishDiagnostics n) = do
227 let List diags = n ^. params . diagnostics
228 doc = n ^. params . uri
230 let newDiags = Map.insert doc diags (curDiagnostics s)
231 in s { curDiagnostics = newDiags })
233 updateState (ReqApplyWorkspaceEdit r) = do
235 allChangeParams <- case r ^. params . edit . documentChanges of
237 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
238 return $ map getParams cs
239 Nothing -> case r ^. params . edit . changes of
241 mapM_ checkIfNeedsOpened (HashMap.keys cs)
242 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
243 Nothing -> error "No changes!"
246 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
247 return $ s { vfs = newVFS }
249 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
250 mergedParams = map mergeParams groupedParams
252 -- TODO: Don't do this when replaying a session
253 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
255 -- Update VFS to new document versions
256 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
257 latestVersions = map ((^. textDocument) . last) sortedVersions
258 bumpedVersions = map (version . _Just +~ 1) latestVersions
260 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
263 update (VirtualFile oldV t mf) = VirtualFile (fromMaybe oldV v) t mf
264 newVFS = Map.adjust update uri oldVFS
265 in s { vfs = newVFS }
267 where checkIfNeedsOpened uri = do
268 oldVFS <- vfs <$> get
271 -- if its not open, open it
272 unless (uri `Map.member` oldVFS) $ do
273 let fp = fromJust $ uriToFilePath uri
274 contents <- liftIO $ T.readFile fp
275 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
276 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
277 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
280 newVFS <- liftIO $ openVFS (vfs s) msg
281 return $ s { vfs = newVFS }
283 getParams (TextDocumentEdit docId (List edits)) =
284 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
285 in DidChangeTextDocumentParams docId (List changeEvents)
287 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
289 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
291 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
293 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
294 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
295 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
296 updateState _ = return ()
298 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
300 h <- serverIn <$> ask
302 liftIO $ B.hPut h (addHeader $ encode msg)
304 -- | Execute a block f that will throw a 'Timeout' exception
305 -- after duration seconds. This will override the global timeout
306 -- for waiting for messages to arrive defined in 'SessionConfig'.
307 withTimeout :: Int -> Session a -> Session a
308 withTimeout duration f = do
309 chan <- asks messageChan
310 timeoutId <- curTimeoutId <$> get
311 modify $ \s -> s { overridingTimeout = True }
313 threadDelay (duration * 1000000)
314 writeChan chan (TimeoutMessage timeoutId)
316 modify $ \s -> s { curTimeoutId = timeoutId + 1,
317 overridingTimeout = False
321 data LogMsgType = LogServer | LogClient
324 -- | Logs the message if the config specified it
325 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
326 => LogMsgType -> a -> m ()
328 shouldLog <- asks $ logMessages . config
329 shouldColor <- asks $ logColor . config
330 liftIO $ when shouldLog $ do
331 when shouldColor $ setSGR [SetColor Foreground Dull color]
332 putStrLn $ arrow ++ showPretty msg
333 when shouldColor $ setSGR [Reset]
336 | t == LogServer = "<-- "
339 | t == LogServer = Magenta
342 showPretty = B.unpack . encodePretty