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 -- runSession \"path\/to\/root\/dir\" $ do
70 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
71 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
72 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
74 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
76 -- | Stuff you can configure for a 'Session'.
77 data SessionConfig = SessionConfig
78 { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60.
79 , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
80 , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to True.
81 , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
84 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
85 defaultConfig :: SessionConfig
86 defaultConfig = SessionConfig 60 False True True
88 instance Default SessionConfig where
91 data SessionMessage = ServerMessage FromServerMessage
95 data SessionContext = SessionContext
99 , messageChan :: Chan SessionMessage
100 , requestMap :: MVar RequestMap
101 , initRsp :: MVar InitializeResponse
102 , config :: SessionConfig
103 , sessionCapabilities :: ClientCapabilities
106 class Monad m => HasReader r m where
108 asks :: (r -> b) -> m b
111 instance Monad m => HasReader r (ParserStateReader a s r m) where
112 ask = lift $ lift Reader.ask
114 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
115 ask = lift $ lift Reader.ask
117 data SessionState = SessionState
121 , curDiagnostics :: Map.Map Uri [Diagnostic]
122 , curTimeoutId :: Int
123 , overridingTimeout :: Bool
124 -- ^ The last received message from the server.
125 -- Used for providing exception information
126 , lastReceivedMessage :: Maybe FromServerMessage
129 class Monad m => HasState s m where
134 modify :: (s -> s) -> m ()
135 modify f = get >>= put . f
137 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
138 modifyM f = get >>= f >>= put
140 instance Monad m => HasState s (ParserStateReader a s r m) where
142 put = lift . State.put
144 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
147 put = lift . State.put
149 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
151 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
152 runSession context state session = runReaderT (runStateT conduit state) context
154 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
156 handler (Unexpected "ConduitParser.empty") = do
157 lastMsg <- fromJust . lastReceivedMessage <$> get
158 name <- getParserName
159 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
164 msg <- liftIO $ readChan (messageChan context)
168 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
169 watchdog = Conduit.awaitForever $ \msg -> do
170 curId <- curTimeoutId <$> get
172 ServerMessage sMsg -> yield sMsg
173 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
175 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
176 -- It also does not automatically send initialize and exit messages.
177 runSessionWithHandles :: Handle -- ^ Server in
178 -> Handle -- ^ Server out
179 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
181 -> ClientCapabilities
182 -> FilePath -- ^ Root directory
185 runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
186 absRootDir <- canonicalizePath rootDir
188 hSetBuffering serverIn NoBuffering
189 hSetBuffering serverOut NoBuffering
191 reqMap <- newMVar newRequestMap
192 messageChan <- newChan
193 initRsp <- newEmptyMVar
195 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
196 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
198 threadId <- forkIO $ void $ serverHandler serverOut context
199 (result, _) <- runSession context initState session
205 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
206 updateStateC = awaitForever $ \msg -> do
210 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
211 updateState (NotPublishDiagnostics n) = do
212 let List diags = n ^. params . diagnostics
213 doc = n ^. params . uri
215 let newDiags = Map.insert doc diags (curDiagnostics s)
216 in s { curDiagnostics = newDiags })
218 updateState (ReqApplyWorkspaceEdit r) = do
220 allChangeParams <- case r ^. params . edit . documentChanges of
222 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
223 return $ map getParams cs
224 Nothing -> case r ^. params . edit . changes of
226 mapM_ checkIfNeedsOpened (HashMap.keys cs)
227 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
228 Nothing -> error "No changes!"
231 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
232 return $ s { vfs = newVFS }
234 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
235 mergedParams = map mergeParams groupedParams
237 -- TODO: Don't do this when replaying a session
238 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
240 -- Update VFS to new document versions
241 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
242 latestVersions = map ((^. textDocument) . last) sortedVersions
243 bumpedVersions = map (version . _Just +~ 1) latestVersions
245 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
248 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
249 newVFS = Map.adjust update uri oldVFS
250 in s { vfs = newVFS }
252 where checkIfNeedsOpened uri = do
253 oldVFS <- vfs <$> get
256 -- if its not open, open it
257 unless (uri `Map.member` oldVFS) $ do
258 let fp = fromJust $ uriToFilePath uri
259 contents <- liftIO $ T.readFile fp
260 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
261 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
262 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
265 newVFS <- liftIO $ openVFS (vfs s) msg
266 return $ s { vfs = newVFS }
268 getParams (TextDocumentEdit docId (List edits)) =
269 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
270 in DidChangeTextDocumentParams docId (List changeEvents)
272 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
274 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
276 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
278 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
279 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
280 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
281 updateState _ = return ()
283 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
285 h <- serverIn <$> ask
287 liftIO $ B.hPut h (addHeader $ encode msg)
289 -- | Execute a block f that will throw a 'TimeoutException'
290 -- after duration seconds. This will override the global timeout
291 -- for waiting for messages to arrive defined in 'SessionConfig'.
292 withTimeout :: Int -> Session a -> Session a
293 withTimeout duration f = do
294 chan <- asks messageChan
295 timeoutId <- curTimeoutId <$> get
296 modify $ \s -> s { overridingTimeout = True }
298 threadDelay (duration * 1000000)
299 writeChan chan (TimeoutMessage timeoutId)
301 modify $ \s -> s { curTimeoutId = timeoutId + 1,
302 overridingTimeout = False
306 data LogMsgType = LogServer | LogClient
309 -- | Logs the message if the config specified it
310 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
311 => LogMsgType -> a -> m ()
313 shouldLog <- asks $ logMessages . config
314 shouldColor <- asks $ logColor . config
315 liftIO $ when shouldLog $ do
316 when shouldColor $ setSGR [SetColor Foreground Dull color]
317 putStrLn $ arrow ++ showPretty msg
318 when shouldColor $ setSGR [Reset]
321 | t == LogServer = "<-- "
324 | t == LogServer = Magenta
327 showPretty = B.unpack . encodePretty