X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=28d4eddec1591fbbe190fc825abc5c0c1453a0f5;hb=c34cfe00bbddb79619129a24086dd763f47cedbc;hp=218defb7cb28fea135b25c1803131e856d2c8046;hpb=35ce787a5458ffdce71923e40464448d6ea71801;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 218defb..28d4edd 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,6 +7,7 @@ module Language.Haskell.LSP.Test.Session ( Session , SessionConfig(..) + , defaultConfig , SessionMessage(..) , SessionContext(..) , SessionState(..) @@ -19,6 +21,8 @@ module Language.Haskell.LSP.Test.Session , sendMessage , updateState , withTimeout + , logMsg + , LogMsgType(..) ) where @@ -29,12 +33,16 @@ import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except +#if __GLASGOW_HASKELL__ >= 806 +import qualified Control.Monad.Fail as Fail +#endif import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT) import qualified Control.Monad.Trans.State as State (get, put) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson +import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default @@ -48,7 +56,8 @@ import Data.Maybe import Data.Function import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions @@ -61,24 +70,23 @@ import System.IO -- You can send and receive messages to the server within 'Session' via 'getMessage', -- 'sendRequest' and 'sendNotification'. -- --- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification --- @ + type Session = ParserStateReader FromServerMessage SessionState SessionContext IO -- | 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 -- ^ Redirect the server's stderr to this stdout, defaults to False. + , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False. + , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. } +-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. +defaultConfig :: SessionConfig +defaultConfig = SessionConfig 60 False False True + instance Default SessionConfig where - def = SessionConfig def 60 False + def = defaultConfig data SessionMessage = ServerMessage FromServerMessage | TimeoutMessage Int @@ -92,6 +100,7 @@ data SessionContext = SessionContext , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities } class Monad m => HasReader r m where @@ -139,6 +148,11 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) +#if __GLASGOW_HASKELL__ >= 806 +instance (Fail.MonadFail m) => Fail.MonadFail (ParserStateReader a s r m) where + fail = Fail.fail +#endif + runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) runSession context state session = runReaderT (runStateT conduit state) context where @@ -156,7 +170,6 @@ runSession context state session = runReaderT (runStateT conduit state) context yield msg chanSource - watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () watchdog = Conduit.awaitForever $ \msg -> do curId <- curTimeoutId <$> get @@ -170,10 +183,11 @@ runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig - -> FilePath + -> ClientCapabilities + -> FilePath -- ^ Root directory -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do +runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -183,7 +197,7 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = messageChan <- newChan initRsp <- 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 @@ -274,14 +288,8 @@ updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () sendMessage msg = do h <- serverIn <$> ask - let encoded = encode msg - liftIO $ do - - setSGR [SetColor Foreground Vivid Cyan] - putStrLn $ "--> " ++ B.unpack encoded - setSGR [Reset] - - B.hPut h (addHeader encoded) + logMsg LogClient msg + liftIO $ B.hPut h (addHeader $ encode msg) -- | Execute a block f that will throw a 'TimeoutException' -- after duration seconds. This will override the global timeout @@ -299,3 +307,26 @@ withTimeout duration f = do overridingTimeout = False } return res + +data LogMsgType = LogServer | LogClient + deriving Eq + +-- | Logs the message if the config specified it +logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m) + => LogMsgType -> a -> m () +logMsg t msg = do + shouldLog <- asks $ logMessages . config + shouldColor <- asks $ logColor . config + liftIO $ when shouldLog $ do + when shouldColor $ setSGR [SetColor Foreground Dull color] + putStrLn $ arrow ++ showPretty msg + when shouldColor $ setSGR [Reset] + + where arrow + | t == LogServer = "<-- " + | otherwise = "--> " + color + | t == LogServer = Magenta + | otherwise = Cyan + + showPretty = B.unpack . encodePretty