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.Aeson.Encode.Pretty
39 import Data.Conduit as Conduit
40 import Data.Conduit.Parser as Parser
44 import qualified Data.Map as Map
45 import qualified Data.Text as T
46 import qualified Data.Text.IO as T
47 import qualified Data.HashMap.Strict as HashMap
50 import Language.Haskell.LSP.Messages
51 import Language.Haskell.LSP.Types.Capabilities
52 import Language.Haskell.LSP.Types hiding (error)
53 import Language.Haskell.LSP.VFS
54 import Language.Haskell.LSP.Test.Decoding
55 import Language.Haskell.LSP.Test.Exceptions
56 import System.Console.ANSI
57 import System.Directory
60 -- | A session representing one instance of launching and connecting to a server.
62 -- You can send and receive messages to the server within 'Session' via 'getMessage',
63 -- 'sendRequest' and 'sendNotification'.
66 -- runSession \"path\/to\/root\/dir\" $ do
67 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
68 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
69 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
71 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
73 -- | Stuff you can configure for a 'Session'.
74 data SessionConfig = SessionConfig
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.
78 , logMessages :: Bool -- ^ When True traces the communication between client and server to stdout. Defaults to True.
81 instance Default SessionConfig where
82 def = SessionConfig 60 False True
84 data SessionMessage = ServerMessage FromServerMessage
88 data SessionContext = SessionContext
92 , messageChan :: Chan SessionMessage
93 , requestMap :: MVar RequestMap
94 , initRsp :: MVar InitializeResponse
95 , config :: SessionConfig
96 , sessionCapabilities :: ClientCapabilities
99 class Monad m => HasReader r m where
101 asks :: (r -> b) -> m b
104 instance Monad m => HasReader r (ParserStateReader a s r m) where
105 ask = lift $ lift Reader.ask
107 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
108 ask = lift $ lift Reader.ask
110 data SessionState = SessionState
114 , curDiagnostics :: Map.Map Uri [Diagnostic]
115 , curTimeoutId :: Int
116 , overridingTimeout :: Bool
117 -- ^ The last received message from the server.
118 -- Used for providing exception information
119 , lastReceivedMessage :: Maybe FromServerMessage
122 class Monad m => HasState s m where
127 modify :: (s -> s) -> m ()
128 modify f = get >>= put . f
130 modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
131 modifyM f = get >>= f >>= put
133 instance Monad m => HasState s (ParserStateReader a s r m) where
135 put = lift . State.put
137 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
140 put = lift . State.put
142 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
144 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
145 runSession context state session = runReaderT (runStateT conduit state) context
147 conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
149 handler (Unexpected "ConduitParser.empty") = do
150 lastMsg <- fromJust . lastReceivedMessage <$> get
151 name <- getParserName
152 liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
157 msg <- liftIO $ readChan (messageChan context)
162 watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
163 watchdog = Conduit.awaitForever $ \msg -> do
164 curId <- curTimeoutId <$> get
166 ServerMessage sMsg -> yield sMsg
167 TimeoutMessage tId -> when (curId == tId) $ throw Timeout
169 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
170 -- It also does not automatically send initialize and exit messages.
171 runSessionWithHandles :: Handle -- ^ Server in
172 -> Handle -- ^ Server out
173 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
175 -> ClientCapabilities
176 -> FilePath -- ^ Root directory
179 runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
180 absRootDir <- canonicalizePath rootDir
182 hSetBuffering serverIn NoBuffering
183 hSetBuffering serverOut NoBuffering
185 reqMap <- newMVar newRequestMap
186 messageChan <- newChan
187 initRsp <- newEmptyMVar
189 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
190 initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
192 threadId <- forkIO $ void $ serverHandler serverOut context
193 (result, _) <- runSession context initState session
199 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
200 updateStateC = awaitForever $ \msg -> do
204 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
205 updateState (NotPublishDiagnostics n) = do
206 let List diags = n ^. params . diagnostics
207 doc = n ^. params . uri
209 let newDiags = Map.insert doc diags (curDiagnostics s)
210 in s { curDiagnostics = newDiags })
212 updateState (ReqApplyWorkspaceEdit r) = do
214 allChangeParams <- case r ^. params . edit . documentChanges of
216 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
217 return $ map getParams cs
218 Nothing -> case r ^. params . edit . changes of
220 mapM_ checkIfNeedsOpened (HashMap.keys cs)
221 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
222 Nothing -> error "No changes!"
225 newVFS <- liftIO $ changeFromServerVFS (vfs s) r
226 return $ s { vfs = newVFS }
228 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
229 mergedParams = map mergeParams groupedParams
231 -- TODO: Don't do this when replaying a session
232 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
234 -- Update VFS to new document versions
235 let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
236 latestVersions = map ((^. textDocument) . last) sortedVersions
237 bumpedVersions = map (version . _Just +~ 1) latestVersions
239 forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
242 update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
243 newVFS = Map.adjust update uri oldVFS
244 in s { vfs = newVFS }
246 where checkIfNeedsOpened uri = do
247 oldVFS <- vfs <$> get
250 -- if its not open, open it
251 unless (uri `Map.member` oldVFS) $ do
252 let fp = fromJust $ uriToFilePath uri
253 contents <- liftIO $ T.readFile fp
254 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
255 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
256 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
259 newVFS <- liftIO $ openVFS (vfs s) msg
260 return $ s { vfs = newVFS }
262 getParams (TextDocumentEdit docId (List edits)) =
263 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
264 in DidChangeTextDocumentParams docId (List changeEvents)
266 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
268 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
270 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
272 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
273 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
274 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
275 updateState _ = return ()
277 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
279 h <- serverIn <$> ask
280 let encoded = encodePretty msg
282 shouldLog <- asks $ logMessages . config
283 liftIO $ when shouldLog $ do
285 setSGR [SetColor Foreground Dull Cyan]
286 putStrLn $ "--> " ++ B.unpack encoded
289 B.hPut h (addHeader encoded)
291 -- | Execute a block f that will throw a 'TimeoutException'
292 -- after duration seconds. This will override the global timeout
293 -- for waiting for messages to arrive defined in 'SessionConfig'.
294 withTimeout :: Int -> Session a -> Session a
295 withTimeout duration f = do
296 chan <- asks messageChan
297 timeoutId <- curTimeoutId <$> get
298 modify $ \s -> s { overridingTimeout = True }
300 threadDelay (duration * 1000000)
301 writeChan chan (TimeoutMessage timeoutId)
303 modify $ \s -> s { curTimeoutId = timeoutId + 1,
304 overridingTimeout = False