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 hiding (error)
56 import Language.Haskell.LSP.VFS
57 import Language.Haskell.LSP.Test.Decoding
58 import Language.Haskell.LSP.Test.Exceptions
59 import System.Console.ANSI
60 import System.Directory
63 -- | A session representing one instance of launching and connecting to a server.
65 -- You can send and receive messages to the server within 'Session' via 'getMessage',
66 -- 'sendRequest' and 'sendNotification'.
69 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
71 -- | Stuff you can configure for a 'Session'.
72 data SessionConfig = SessionConfig
73 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
74 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
75 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to True.
76 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
79 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
80 defaultConfig :: SessionConfig
81 defaultConfig = SessionConfig 60 False True True
83 instance Default SessionConfig where
86 data SessionMessage = ServerMessage FromServerMessage
90 data SessionContext = SessionContext
94 , messageChan :: Chan SessionMessage
95 , requestMap :: MVar RequestMap
96 , initRsp :: MVar InitializeResponse
97 , config :: SessionConfig
98 , sessionCapabilities :: ClientCapabilities
101 class Monad m => HasReader r m where
103 asks :: (r -> b) -> m b
106 instance Monad m => HasReader r (ParserStateReader a s r m) where
107 ask = lift $ lift Reader.ask
109 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
110 ask = lift $ lift Reader.ask
112 data SessionState = SessionState
116 , curDiagnostics :: Map.Map Uri [Diagnostic]
117 , curTimeoutId :: Int
118 , overridingTimeout :: Bool
119 -- ^ The last received message from the server.
120 -- Used for providing exception information
121 , lastReceivedMessage :: Maybe FromServerMessage
124 class Monad m => HasState s m where
129 modify :: (s -> s) -> m ()
130 modify f = get >>= put . f
132 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
133 modifyM f = get >>= f >>= put
135 instance Monad m => HasState s (ParserStateReader a s r m) where
137 put = lift . State.put
139 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
142 put = lift . State.put
144 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
146 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
147 runSession context state session = runReaderT (runStateT conduit state) context
149 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
151 handler (Unexpected "ConduitParser.empty") = do
152 lastMsg <- fromJust . lastReceivedMessage <$> get
153 name <- getParserName
154 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
159 msg <- liftIO $ readChan (messageChan context)
163 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
164 watchdog = Conduit.awaitForever $ \msg -> do
165 curId <- curTimeoutId <$> get
167 ServerMessage sMsg -> yield sMsg
168 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
170 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
171 -- It also does not automatically send initialize and exit messages.
172 runSessionWithHandles :: Handle -- ^ Server in
173 -> Handle -- ^ Server out
174 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
176 -> ClientCapabilities
177 -> FilePath -- ^ Root directory
180 runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
181 absRootDir <- canonicalizePath rootDir
183 hSetBuffering serverIn NoBuffering
184 hSetBuffering serverOut NoBuffering
186 reqMap <- newMVar newRequestMap
187 messageChan <- newChan
188 initRsp <- newEmptyMVar
190 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
191 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
193 threadId <- forkIO $ void $ serverHandler serverOut context
194 (result, _) <- runSession context initState session
200 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
201 updateStateC = awaitForever $ \msg -> do
205 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
206 updateState (NotPublishDiagnostics n) = do
207 let List diags = n ^. params . diagnostics
208 doc = n ^. params . uri
210 let newDiags = Map.insert doc diags (curDiagnostics s)
211 in s { curDiagnostics = newDiags })
213 updateState (ReqApplyWorkspaceEdit r) = do
215 allChangeParams <- case r ^. params . edit . documentChanges of
217 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
218 return $ map getParams cs
219 Nothing -> case r ^. params . edit . changes of
221 mapM_ checkIfNeedsOpened (HashMap.keys cs)
222 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
223 Nothing -> error "No changes!"
226 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
227 return $ s { vfs = newVFS }
229 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
230 mergedParams = map mergeParams groupedParams
232 -- TODO: Don't do this when replaying a session
233 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
235 -- Update VFS to new document versions
236 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
237 latestVersions = map ((^. textDocument) . last) sortedVersions
238 bumpedVersions = map (version . _Just +~ 1) latestVersions
240 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
243 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
244 newVFS = Map.adjust update uri oldVFS
245 in s { vfs = newVFS }
247 where checkIfNeedsOpened uri = do
248 oldVFS <- vfs <$> get
251 -- if its not open, open it
252 unless (uri `Map.member` oldVFS) $ do
253 let fp = fromJust $ uriToFilePath uri
254 contents <- liftIO $ T.readFile fp
255 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
256 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
257 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
260 newVFS <- liftIO $ openVFS (vfs s) msg
261 return $ s { vfs = newVFS }
263 getParams (TextDocumentEdit docId (List edits)) =
264 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
265 in DidChangeTextDocumentParams docId (List changeEvents)
267 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
269 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
271 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
273 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
274 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
275 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
276 updateState _ = return ()
278 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
280 h <- serverIn <$> ask
282 liftIO $ B.hPut h (addHeader $ encode msg)
284 -- | Execute a block f that will throw a 'TimeoutException'
285 -- after duration seconds. This will override the global timeout
286 -- for waiting for messages to arrive defined in 'SessionConfig'.
287 withTimeout :: Int -> Session a -> Session a
288 withTimeout duration f = do
289 chan <- asks messageChan
290 timeoutId <- curTimeoutId <$> get
291 modify $ \s -> s { overridingTimeout = True }
293 threadDelay (duration * 1000000)
294 writeChan chan (TimeoutMessage timeoutId)
296 modify $ \s -> s { curTimeoutId = timeoutId + 1,
297 overridingTimeout = False
301 data LogMsgType = LogServer | LogClient
304 -- | Logs the message if the config specified it
305 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
306 => LogMsgType -> a -> m ()
308 shouldLog <- asks $ logMessages . config
309 shouldColor <- asks $ logColor . config
310 liftIO $ when shouldLog $ do
311 when shouldColor $ setSGR [SetColor Foreground Dull color]
312 putStrLn $ arrow ++ showPretty msg
313 when shouldColor $ setSGR [Reset]
316 | t == LogServer = "<-- "
319 | t == LogServer = Magenta
322 showPretty = B.unpack . encodePretty