{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
module Language.Haskell.LSP.Test.Session
- ( Session
+ ( SessionT
, SessionConfig(..)
, SessionMessage(..)
, SessionContext(..)
, get
, put
, modify
+ , modifyM
, ask
, asks
, sendMessage
where
+import Conduit
import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Lens hiding (List)
import qualified Control.Monad.Trans.State as State (get, put)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson
-import Data.Conduit as Conduit
+import Data.Aeson.Encode.Pretty
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
-- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
-- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
-- @
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+type SessionT m = ParserStateReader FromServerMessage SessionState SessionContext m
-- | Stuff you can configure for a 'Session'.
data SessionConfig = SessionConfig
{
- capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
- , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
- , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
+ messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
+ , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False.
+ , logMessages :: Bool -- ^ When True traces the communication between client and server to stdout. Defaults to True.
}
instance Default SessionConfig where
- def = SessionConfig def 60 False
+ def = SessionConfig 60 False True
data SessionMessage = ServerMessage FromServerMessage
| TimeoutMessage Int
, requestMap :: MVar RequestMap
, initRsp :: MVar InitializeResponse
, config :: SessionConfig
+ , sessionCapabilities :: ClientCapabilities
}
class Monad m => HasReader r m where
modify :: (s -> s) -> m ()
modify f = get >>= put . f
+ modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
+ modifyM f = get >>= f >>= put
+
instance Monad m => HasState s (ParserStateReader a s r m) where
get = lift State.get
put = lift . State.put
type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state session =
- -- source <- sourceList <$> getChanContents (messageChan context)
- runReaderT (runStateT conduit state) context
+runSession :: (MonadIO m, MonadThrow m) => SessionContext -> SessionState -> SessionT m a -> m (a, SessionState)
+runSession context state session = runReaderT (runStateT conduit state) context
where
conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
+ handler :: MonadIO m => ConduitParserException -> SessionT m a
handler (Unexpected "ConduitParser.empty") = do
lastMsg <- fromJust . lastReceivedMessage <$> get
name <- getParserName
- liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
+ liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
- handler e = throw e
+ handler e = liftIO $ throw e
+ chanSource :: MonadIO m => ConduitT () SessionMessage m ()
chanSource = do
msg <- liftIO $ readChan (messageChan context)
yield msg
chanSource
- watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+ watchdog :: MonadIO m => ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) ()
watchdog = Conduit.awaitForever $ \msg -> do
curId <- curTimeoutId <$> get
case msg of
ServerMessage sMsg -> yield sMsg
- TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException
+ TimeoutMessage tId -> when (curId == tId) $ throw Timeout
-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
-runSessionWithHandles :: Handle -- ^ Server in
+runSessionWithHandles :: (MonadIO m, MonadThrow m)
+ => Handle -- ^ Server in
-> Handle -- ^ Server out
-> (Handle -> SessionContext -> IO ()) -- ^ Server listener
-> SessionConfig
- -> FilePath
- -> Session a
- -> IO a
-runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
- absRootDir <- canonicalizePath rootDir
+ -> ClientCapabilities
+ -> FilePath -- ^ Root directory
+ -> SessionT m a
+ -> m a
+runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
+ absRootDir <- liftIO $ canonicalizePath rootDir
+ liftIO $ do
hSetBuffering serverIn NoBuffering
hSetBuffering serverOut NoBuffering
- reqMap <- newMVar newRequestMap
- messageChan <- newChan
- initRsp <- newEmptyMVar
+ reqMap <- liftIO $ newMVar newRequestMap
+ messageChan <- liftIO newChan
+ initRsp <- liftIO newEmptyMVar
- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
+ let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
- threadId <- forkIO $ void $ serverHandler serverOut context
+ threadId <- liftIO $ forkIO $ void $ serverHandler serverOut context
(result, _) <- runSession context initState session
- killThread threadId
+ liftIO $ killThread threadId
return result
-updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+updateStateC :: MonadIO m => ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) ()
updateStateC = awaitForever $ \msg -> do
updateState msg
yield msg
updateState (ReqApplyWorkspaceEdit r) = do
- oldVFS <- vfs <$> get
-
allChangeParams <- case r ^. params . edit . documentChanges of
Just (List cs) -> do
mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
Nothing -> error "No changes!"
- newVFS <- liftIO $ changeFromServerVFS oldVFS r
- modify (\s -> s { vfs = newVFS })
+ modifyM $ \s -> do
+ newVFS <- liftIO $ changeFromServerVFS (vfs s) r
+ return $ s { vfs = newVFS }
let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
mergedParams = map mergeParams groupedParams
msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
- oldVFS <- vfs <$> get
- newVFS <- liftIO $ openVFS oldVFS msg
- modify (\s -> s { vfs = newVFS })
+ modifyM $ \s -> do
+ newVFS <- liftIO $ openVFS (vfs s) msg
+ return $ s { vfs = newVFS }
getParams (TextDocumentEdit docId (List edits)) =
let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage msg = do
h <- serverIn <$> ask
- let encoded = encode msg
- liftIO $ do
+ let encoded = encodePretty msg
+
+ shouldLog <- asks $ logMessages . config
+ liftIO $ when shouldLog $ do
- setSGR [SetColor Foreground Vivid Cyan]
+ setSGR [SetColor Foreground Dull Cyan]
putStrLn $ "--> " ++ B.unpack encoded
setSGR [Reset]
-- | Execute a block f that will throw a 'TimeoutException'
-- after duration seconds. This will override the global timeout
-- for waiting for messages to arrive defined in 'SessionConfig'.
-withTimeout :: Int -> Session a -> Session a
+withTimeout :: MonadIO m => Int -> SessionT m a -> SessionT m a
withTimeout duration f = do
chan <- asks messageChan
timeoutId <- curTimeoutId <$> get
projects / lsp-test.git / blobdiff