1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE FlexibleContexts #-}
6 module Language.Haskell.LSP.Test.Session
12 , runSessionWithHandles
26 import Control.Concurrent hiding (yield)
27 import Control.Exception
28 import Control.Lens hiding (List)
30 import Control.Monad.IO.Class
31 import Control.Monad.Except
32 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
33 import qualified Control.Monad.Trans.Reader as Reader (ask)
34 import Control.Monad.Trans.State (StateT, runStateT)
35 import qualified Control.Monad.Trans.State as State (get, put)
36 import qualified Data.ByteString.Lazy.Char8 as B
38 import Data.Conduit as Conduit
39 import Data.Conduit.Parser as Parser
43 import qualified Data.Map as Map
44 import qualified Data.Text as T
45 import qualified Data.Text.IO as T
46 import qualified Data.HashMap.Strict as HashMap
49 import Language.Haskell.LSP.Messages
50 import Language.Haskell.LSP.Types.Capabilities
51 import Language.Haskell.LSP.Types hiding (error)
52 import Language.Haskell.LSP.VFS
53 import Language.Haskell.LSP.Test.Decoding
54 import Language.Haskell.LSP.Test.Exceptions
55 import System.Console.ANSI
56 import System.Directory
59 -- | A session representing one instance of launching and connecting to a server.
61 -- You can send and receive messages to the server within 'Session' via 'getMessage',
62 -- 'sendRequest' and 'sendNotification'.
65 -- runSession \"path\/to\/root\/dir\" $ do
66 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
67 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
68 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
70 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
72 -- | Stuff you can configure for a 'Session'.
73 data SessionConfig = SessionConfig
75 capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
76 , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
77 , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
80 instance Default SessionConfig where
81 def = SessionConfig def 60 False
83 data SessionMessage = ServerMessage FromServerMessage
87 data SessionContext = SessionContext
91 , messageChan :: Chan SessionMessage
92 , requestMap :: MVar RequestMap
93 , initRsp :: MVar InitializeResponse
94 , config :: SessionConfig
97 class Monad m => HasReader r m where
99 asks :: (r -> b) -> m b
102 instance Monad m => HasReader r (ParserStateReader a s r m) where
103 ask = lift $ lift Reader.ask
105 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
106 ask = lift $ lift Reader.ask
108 data SessionState = SessionState
112 , curDiagnostics :: Map.Map Uri [Diagnostic]
113 , curTimeoutId :: Int
114 , overridingTimeout :: Bool
115 -- ^ The last received message from the server.
116 -- Used for providing exception information
117 , lastReceivedMessage :: Maybe FromServerMessage
120 class Monad m => HasState s m where
125 modify :: (s -> s) -> m ()
126 modify f = get >>= put . f
128 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
129 modifyM f = get >>= f >>= put
131 instance Monad m => HasState s (ParserStateReader a s r m) where
133 put = lift . State.put
135 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
138 put = lift . State.put
140 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
142 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
143 runSession context state session = runReaderT (runStateT conduit state) context
145 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
147 handler (Unexpected "ConduitParser.empty") = do
148 lastMsg <- fromJust . lastReceivedMessage <$> get
149 name <- getParserName
150 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
155 msg <- liftIO $ readChan (messageChan context)
160 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
161 watchdog = Conduit.awaitForever $ \msg -> do
162 curId <- curTimeoutId <$> get
164 ServerMessage sMsg -> yield sMsg
165 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
167 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
168 -- It also does not automatically send initialize and exit messages.
169 runSessionWithHandles :: Handle -- ^ Server in
170 -> Handle -- ^ Server out
171 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
176 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
177 absRootDir <- canonicalizePath rootDir
179 hSetBuffering serverIn NoBuffering
180 hSetBuffering serverOut NoBuffering
182 reqMap <- newMVar newRequestMap
183 messageChan <- newChan
184 initRsp <- newEmptyMVar
186 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
187 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
189 threadId <- forkIO $ void $ serverHandler serverOut context
190 (result, _) <- runSession context initState session
196 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
197 updateStateC = awaitForever $ \msg -> do
201 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
202 updateState (NotPublishDiagnostics n) = do
203 let List diags = n ^. params . diagnostics
204 doc = n ^. params . uri
206 let newDiags = Map.insert doc diags (curDiagnostics s)
207 in s { curDiagnostics = newDiags })
209 updateState (ReqApplyWorkspaceEdit r) = do
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!"
222 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
223 return $ s { vfs = newVFS }
225 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
226 mergedParams = map mergeParams groupedParams
228 -- TODO: Don't do this when replaying a session
229 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
231 -- Update VFS to new document versions
232 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
233 latestVersions = map ((^. textDocument) . last) sortedVersions
234 bumpedVersions = map (version . _Just +~ 1) latestVersions
236 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
239 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
240 newVFS = Map.adjust update uri oldVFS
241 in s { vfs = newVFS }
243 where checkIfNeedsOpened uri = do
244 oldVFS <- vfs <$> get
247 -- if its not open, open it
248 unless (uri `Map.member` oldVFS) $ do
249 let fp = fromJust $ uriToFilePath uri
250 contents <- liftIO $ T.readFile fp
251 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
252 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
253 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
256 newVFS <- liftIO $ openVFS (vfs s) msg
257 return $ s { vfs = newVFS }
259 getParams (TextDocumentEdit docId (List edits)) =
260 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
261 in DidChangeTextDocumentParams docId (List changeEvents)
263 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
265 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
267 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
269 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
270 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
271 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
272 updateState _ = return ()
274 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
276 h <- serverIn <$> ask
277 let encoded = encode msg
280 setSGR [SetColor Foreground Vivid Cyan]
281 putStrLn $ "--> " ++ B.unpack encoded
284 B.hPut h (addHeader encoded)
286 -- | Execute a block f that will throw a 'TimeoutException'
287 -- after duration seconds. This will override the global timeout
288 -- for waiting for messages to arrive defined in 'SessionConfig'.
289 withTimeout :: Int -> Session a -> Session a
290 withTimeout duration f = do
291 chan <- asks messageChan
292 timeoutId <- curTimeoutId <$> get
293 modify $ \s -> s { overridingTimeout = True }
295 threadDelay (duration * 1000000)
296 writeChan chan (TimeoutMessage timeoutId)
298 modify $ \s -> s { curTimeoutId = timeoutId + 1,
299 overridingTimeout = False