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
48 import Language.Haskell.LSP.Messages
49 import Language.Haskell.LSP.TH.ClientCapabilities
50 import Language.Haskell.LSP.Types hiding (error)
51 import Language.Haskell.LSP.VFS
52 import Language.Haskell.LSP.Test.Decoding
53 import Language.Haskell.LSP.Test.Exceptions
54 import System.Console.ANSI
55 import System.Directory
58 -- | A session representing one instance of launching and connecting to a server.
60 -- You can send and receive messages to the server within 'Session' via 'getMessage',
61 -- 'sendRequest' and 'sendNotification'.
64 -- runSession \"path\/to\/root\/dir\" $ do
65 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
66 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
67 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
69 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
71 -- | Stuff you can configure for a 'Session'.
72 data SessionConfig = SessionConfig
74 capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
75 , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
76 , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
79 instance Default SessionConfig where
80 def = SessionConfig def 60 False
82 data SessionMessage = ServerMessage FromServerMessage
86 data SessionContext = SessionContext
90 , messageChan :: Chan SessionMessage
91 , requestMap :: MVar RequestMap
92 , initRsp :: MVar InitializeResponse
93 , config :: SessionConfig
96 class Monad m => HasReader r m where
98 asks :: (r -> b) -> m b
101 instance Monad m => HasReader r (ParserStateReader a s r m) where
102 ask = lift $ lift Reader.ask
104 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
105 ask = lift $ lift Reader.ask
107 data SessionState = SessionState
111 , curDiagnostics :: Map.Map Uri [Diagnostic]
112 , curTimeoutId :: Int
113 , overridingTimeout :: Bool
114 -- ^ The last received message from the server.
115 -- Used for providing exception information
116 , lastReceivedMessage :: Maybe FromServerMessage
119 class Monad m => HasState s m where
124 modify :: (s -> s) -> m ()
125 modify f = get >>= put . f
127 instance Monad m => HasState s (ParserStateReader a s r m) where
129 put = lift . State.put
131 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
134 put = lift . State.put
136 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
138 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
139 runSession context state session =
140 -- source <- sourceList <$> getChanContents (messageChan context)
141 runReaderT (runStateT conduit state) context
143 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
145 handler (Unexpected "ConduitParser.empty") = do
146 lastMsg <- fromJust . lastReceivedMessage <$> get
147 name <- getParserName
148 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
153 msg <- liftIO $ readChan (messageChan context)
158 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
159 watchdog = Conduit.awaitForever $ \msg -> do
160 curId <- curTimeoutId <$> get
162 ServerMessage sMsg -> yield sMsg
163 TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException
165 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
166 -- It also does not automatically send initialize and exit messages.
167 runSessionWithHandles :: Handle -- ^ Server in
168 -> Handle -- ^ Server out
169 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
174 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
175 absRootDir <- canonicalizePath rootDir
177 hSetBuffering serverIn NoBuffering
178 hSetBuffering serverOut NoBuffering
180 reqMap <- newMVar newRequestMap
181 messageChan <- newChan
182 initRsp <- newEmptyMVar
184 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
185 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
187 threadId <- forkIO $ void $ serverHandler serverOut context
188 (result, _) <- runSession context initState session
194 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
195 updateStateC = awaitForever $ \msg -> do
199 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
200 updateState (NotPublishDiagnostics n) = do
201 let List diags = n ^. params . diagnostics
202 doc = n ^. params . uri
204 let newDiags = Map.insert doc diags (curDiagnostics s)
205 in s { curDiagnostics = newDiags })
207 updateState (ReqApplyWorkspaceEdit r) = do
209 oldVFS <- vfs <$> get
211 allChangeParams <- case r ^. params . edit . documentChanges of
213 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
214 return $ map getParams cs
215 Nothing -> case r ^. params . edit . changes of
217 mapM_ checkIfNeedsOpened (HashMap.keys cs)
218 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
219 Nothing -> error "No changes!"
221 newVFS <- liftIO $ changeFromServerVFS oldVFS r
222 modify (\s -> s { vfs = newVFS })
224 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
225 mergedParams = map mergeParams groupedParams
227 -- TODO: Don't do this when replaying a session
228 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
230 -- Update VFS to new document versions
231 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
232 latestVersions = map ((^. textDocument) . last) sortedVersions
233 bumpedVersions = map (version . _Just +~ 1) latestVersions
235 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
238 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
239 newVFS = Map.adjust update uri oldVFS
240 in s { vfs = newVFS }
242 where checkIfNeedsOpened uri = do
243 oldVFS <- vfs <$> get
246 -- if its not open, open it
247 unless (uri `Map.member` oldVFS) $ do
248 let fp = fromJust $ uriToFilePath uri
249 contents <- liftIO $ T.readFile fp
250 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
251 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
252 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
254 oldVFS <- vfs <$> get
255 newVFS <- liftIO $ openVFS oldVFS msg
256 modify (\s -> s { vfs = newVFS })
258 getParams (TextDocumentEdit docId (List edits)) =
259 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
260 in DidChangeTextDocumentParams docId (List changeEvents)
262 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
264 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
266 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
268 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
269 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
270 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
271 updateState _ = return ()
273 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
275 h <- serverIn <$> ask
276 let encoded = encode msg
279 setSGR [SetColor Foreground Vivid Cyan]
280 putStrLn $ "--> " ++ B.unpack encoded
283 B.hPut h (addHeader encoded)
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