1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE FlexibleContexts #-}
6 module Language.Haskell.LSP.Test.Session
12 , runSessionWithHandles
25 import Control.Concurrent hiding (yield)
26 import Control.Exception
27 import Control.Lens hiding (List)
29 import Control.Monad.IO.Class
30 import Control.Monad.Except
31 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
32 import qualified Control.Monad.Trans.Reader as Reader (ask)
33 import Control.Monad.Trans.State (StateT, runStateT)
34 import qualified Control.Monad.Trans.State as State (get, put)
35 import qualified Data.ByteString.Lazy.Char8 as B
37 import Data.Conduit as Conduit
38 import Data.Conduit.Parser as Parser
42 import qualified Data.Map as Map
43 import qualified Data.Text as T
44 import qualified Data.Text.IO as T
45 import qualified Data.HashMap.Strict as HashMap
47 import Language.Haskell.LSP.Messages
48 import Language.Haskell.LSP.TH.ClientCapabilities
49 import Language.Haskell.LSP.Types hiding (error)
50 import Language.Haskell.LSP.VFS
51 import Language.Haskell.LSP.Test.Decoding
52 import Language.Haskell.LSP.Test.Exceptions
53 import System.Console.ANSI
54 import System.Directory
57 -- | A session representing one instance of launching and connecting to a server.
59 -- You can send and receive messages to the server within 'Session' via 'getMessage',
60 -- 'sendRequest' and 'sendNotification'.
63 -- runSession \"path\/to\/root\/dir\" $ do
64 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
65 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
66 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
68 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
70 -- | Stuff you can configure for a 'Session'.
71 data SessionConfig = SessionConfig
73 capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
74 , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
75 , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
78 instance Default SessionConfig where
79 def = SessionConfig def 60 False
81 data SessionMessage = ServerMessage FromServerMessage
85 data SessionContext = SessionContext
89 , messageChan :: Chan SessionMessage
90 , requestMap :: MVar RequestMap
91 , initRsp :: MVar InitializeResponse
92 , config :: SessionConfig
95 class Monad m => HasReader r m where
97 asks :: (r -> b) -> m b
100 instance Monad m => HasReader r (ParserStateReader a s r m) where
101 ask = lift $ lift Reader.ask
103 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
104 ask = lift $ lift Reader.ask
106 data SessionState = SessionState
110 , curDiagnostics :: Map.Map Uri [Diagnostic]
111 , curTimeoutId :: Int
112 , overridingTimeout :: Bool
113 -- ^ The last received message from the server.
114 -- Used for providing exception information
115 , lastReceivedMessage :: Maybe FromServerMessage
118 class Monad m => HasState s m where
123 modify :: (s -> s) -> m ()
124 modify f = get >>= put . f
126 instance Monad m => HasState s (ParserStateReader a s r m) where
128 put = lift . State.put
130 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
133 put = lift . State.put
135 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
137 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
138 runSession context state session =
139 -- source <- sourceList <$> getChanContents (messageChan context)
140 runReaderT (runStateT conduit state) context
142 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
144 handler (Unexpected "ConduitParser.empty") = do
145 lastMsg <- fromJust . lastReceivedMessage <$> get
146 name <- getParserName
147 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
152 msg <- liftIO $ readChan (messageChan context)
157 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
158 watchdog = Conduit.awaitForever $ \msg -> do
159 curId <- curTimeoutId <$> get
161 ServerMessage sMsg -> yield sMsg
162 TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException
164 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
165 -- It also does not automatically send initialize and exit messages.
166 runSessionWithHandles :: Handle -- ^ Server in
167 -> Handle -- ^ Server out
168 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
173 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
174 absRootDir <- canonicalizePath rootDir
176 hSetBuffering serverIn NoBuffering
177 hSetBuffering serverOut NoBuffering
179 reqMap <- newMVar newRequestMap
180 messageChan <- newChan
181 initRsp <- newEmptyMVar
183 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
184 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
186 threadId <- forkIO $ void $ serverHandler serverOut context
187 (result, _) <- runSession context initState session
193 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
194 updateStateC = awaitForever $ \msg -> do
198 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
199 updateState (NotPublishDiagnostics n) = do
200 let List diags = n ^. params . diagnostics
201 doc = n ^. params . uri
203 let newDiags = Map.insert doc diags (curDiagnostics s)
204 in s { curDiagnostics = newDiags })
206 updateState (ReqApplyWorkspaceEdit r) = do
208 allChangeParams <- case r ^. params . edit . documentChanges of
210 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
211 return $ map getParams cs
212 Nothing -> case r ^. params . edit . changes of
214 mapM_ checkIfNeedsOpened (HashMap.keys cs)
215 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
216 Nothing -> error "No changes!"
218 oldVFS <- vfs <$> get
219 newVFS <- liftIO $ changeFromServerVFS oldVFS r
220 modify (\s -> s { vfs = newVFS })
222 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
223 mergedParams = map mergeParams groupedParams
225 -- TODO: Don't do this when replaying a session
226 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
228 where checkIfNeedsOpened uri = do
229 oldVFS <- vfs <$> get
232 -- if its not open, open it
233 unless (uri `Map.member` oldVFS) $ do
234 let fp = fromJust $ uriToFilePath uri
235 contents <- liftIO $ T.readFile fp
236 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
237 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
238 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
240 oldVFS <- vfs <$> get
241 newVFS <- liftIO $ openVFS oldVFS msg
242 modify (\s -> s { vfs = newVFS })
244 getParams (TextDocumentEdit docId (List edits)) =
245 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
246 in DidChangeTextDocumentParams docId (List changeEvents)
248 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
250 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
252 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
254 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
255 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
256 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
257 updateState _ = return ()
259 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
261 h <- serverIn <$> ask
262 let encoded = encode msg
265 setSGR [SetColor Foreground Vivid Cyan]
266 putStrLn $ "--> " ++ B.unpack encoded
269 B.hPut h (addHeader encoded)
271 -- | Execute a block f that will throw a 'TimeoutException'
272 -- after duration seconds. This will override the global timeout
273 -- for waiting for messages to arrive defined in 'SessionConfig'.
274 withTimeout :: Int -> Session a -> Session a
275 withTimeout duration f = do
276 chan <- asks messageChan
277 timeoutId <- curTimeoutId <$> get
278 modify $ \s -> s { overridingTimeout = True }
280 threadDelay (duration * 1000000)
281 writeChan chan (TimeoutMessage timeoutId)
283 modify $ \s -> s { curTimeoutId = timeoutId + 1,
284 overridingTimeout = False