1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE FlexibleContexts #-}
6 module Language.Haskell.LSP.Test.Session
13 , runSessionWithHandles
29 import Control.Concurrent hiding (yield)
30 import Control.Exception
31 import Control.Lens hiding (List)
33 import Control.Monad.IO.Class
34 import Control.Monad.Except
35 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
36 import qualified Control.Monad.Trans.Reader as Reader (ask)
37 import Control.Monad.Trans.State (StateT, runStateT)
38 import qualified Control.Monad.Trans.State as State (get, put)
39 import qualified Data.ByteString.Lazy.Char8 as B
41 import Data.Aeson.Encode.Pretty
42 import Data.Conduit as Conduit
43 import Data.Conduit.Parser as Parser
47 import qualified Data.Map as Map
48 import qualified Data.Text as T
49 import qualified Data.Text.IO as T
50 import qualified Data.HashMap.Strict as HashMap
53 import Language.Haskell.LSP.Messages
54 import Language.Haskell.LSP.Types.Capabilities
55 import Language.Haskell.LSP.Types
56 import Language.Haskell.LSP.Types.Lens hiding (error)
57 import Language.Haskell.LSP.VFS
58 import Language.Haskell.LSP.Test.Decoding
59 import Language.Haskell.LSP.Test.Exceptions
60 import System.Console.ANSI
61 import System.Directory
64 -- | A session representing one instance of launching and connecting to a server.
66 -- You can send and receive messages to the server within 'Session' via 'getMessage',
67 -- 'sendRequest' and 'sendNotification'.
70 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
72 -- | Stuff you can configure for a 'Session'.
73 data SessionConfig = SessionConfig
74 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
75 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
76 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False.
77 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
80 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
81 defaultConfig :: SessionConfig
82 defaultConfig = SessionConfig 60 False False True
84 instance Default SessionConfig where
87 data SessionMessage = ServerMessage FromServerMessage
91 data SessionContext = SessionContext
95 , messageChan :: Chan SessionMessage
96 , requestMap :: MVar RequestMap
97 , initRsp :: MVar InitializeResponse
98 , config :: SessionConfig
99 , sessionCapabilities :: ClientCapabilities
102 class Monad m => HasReader r m where
104 asks :: (r -> b) -> m b
107 instance Monad m => HasReader r (ParserStateReader a s r m) where
108 ask = lift $ lift Reader.ask
110 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
111 ask = lift $ lift Reader.ask
113 data SessionState = SessionState
117 , curDiagnostics :: Map.Map Uri [Diagnostic]
118 , curTimeoutId :: Int
119 , overridingTimeout :: Bool
120 -- ^ The last received message from the server.
121 -- Used for providing exception information
122 , lastReceivedMessage :: Maybe FromServerMessage
125 class Monad m => HasState s m where
130 modify :: (s -> s) -> m ()
131 modify f = get >>= put . f
133 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
134 modifyM f = get >>= f >>= put
136 instance Monad m => HasState s (ParserStateReader a s r m) where
138 put = lift . State.put
140 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
143 put = lift . State.put
145 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
147 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
148 runSession context state session = runReaderT (runStateT conduit state) context
150 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
152 handler (Unexpected "ConduitParser.empty") = do
153 lastMsg <- fromJust . lastReceivedMessage <$> get
154 name <- getParserName
155 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
160 msg <- liftIO $ readChan (messageChan context)
164 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
165 watchdog = Conduit.awaitForever $ \msg -> do
166 curId <- curTimeoutId <$> get
168 ServerMessage sMsg -> yield sMsg
169 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
171 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
172 -- It also does not automatically send initialize and exit messages.
173 runSessionWithHandles :: Handle -- ^ Server in
174 -> Handle -- ^ Server out
175 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
177 -> ClientCapabilities
178 -> FilePath -- ^ Root directory
181 runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
182 absRootDir <- canonicalizePath rootDir
184 hSetBuffering serverIn NoBuffering
185 hSetBuffering serverOut NoBuffering
187 reqMap <- newMVar newRequestMap
188 messageChan <- newChan
189 initRsp <- newEmptyMVar
191 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
192 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
194 threadId <- forkIO $ void $ serverHandler serverOut context
195 (result, _) <- runSession context initState session
201 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
202 updateStateC = awaitForever $ \msg -> do
206 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
207 updateState (NotPublishDiagnostics n) = do
208 let List diags = n ^. params . diagnostics
209 doc = n ^. params . uri
211 let newDiags = Map.insert doc diags (curDiagnostics s)
212 in s { curDiagnostics = newDiags })
214 updateState (ReqApplyWorkspaceEdit r) = do
216 allChangeParams <- case r ^. params . edit . documentChanges of
218 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
219 return $ map getParams cs
220 Nothing -> case r ^. params . edit . changes of
222 mapM_ checkIfNeedsOpened (HashMap.keys cs)
223 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
224 Nothing -> error "No changes!"
227 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
228 return $ s { vfs = newVFS }
230 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
231 mergedParams = map mergeParams groupedParams
233 -- TODO: Don't do this when replaying a session
234 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
236 -- Update VFS to new document versions
237 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
238 latestVersions = map ((^. textDocument) . last) sortedVersions
239 bumpedVersions = map (version . _Just +~ 1) latestVersions
241 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
244 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
245 newVFS = Map.adjust update uri oldVFS
246 in s { vfs = newVFS }
248 where checkIfNeedsOpened uri = do
249 oldVFS <- vfs <$> get
252 -- if its not open, open it
253 unless (uri `Map.member` oldVFS) $ do
254 let fp = fromJust $ uriToFilePath uri
255 contents <- liftIO $ T.readFile fp
256 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
257 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
258 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
261 newVFS <- liftIO $ openVFS (vfs s) msg
262 return $ s { vfs = newVFS }
264 getParams (TextDocumentEdit docId (List edits)) =
265 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
266 in DidChangeTextDocumentParams docId (List changeEvents)
268 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
270 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
272 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
274 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
275 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
276 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
277 updateState _ = return ()
279 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
281 h <- serverIn <$> ask
283 liftIO $ B.hPut h (addHeader $ encode msg)
285 -- | Execute a block f that will throw a 'TimeoutException'
286 -- after duration seconds. This will override the global timeout
287 -- for waiting for messages to arrive defined in 'SessionConfig'.
288 withTimeout :: Int -> Session a -> Session a
289 withTimeout duration f = do
290 chan <- asks messageChan
291 timeoutId <- curTimeoutId <$> get
292 modify $ \s -> s { overridingTimeout = True }
294 threadDelay (duration * 1000000)
295 writeChan chan (TimeoutMessage timeoutId)
297 modify $ \s -> s { curTimeoutId = timeoutId + 1,
298 overridingTimeout = False
302 data LogMsgType = LogServer | LogClient
305 -- | Logs the message if the config specified it
306 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
307 => LogMsgType -> a -> m ()
309 shouldLog <- asks $ logMessages . config
310 shouldColor <- asks $ logColor . config
311 liftIO $ when shouldLog $ do
312 when shouldColor $ setSGR [SetColor Foreground Dull color]
313 putStrLn $ arrow ++ showPretty msg
314 when shouldColor $ setSGR [Reset]
317 | t == LogServer = "<-- "
320 | t == LogServer = Magenta
323 showPretty = B.unpack . encodePretty