Pretty print message trace

[lsp-test.git] / src / Language / Haskell / LSP / Test / Session.hs

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 218defb7cb28fea135b25c1803131e856d2c8046..a58496d5234dff41854b0f5baba401658daeffc7 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -35,6 +35,7 @@ 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
@@ -72,13 +73,13 @@ type Session = ParserStateReader FromServerMessage SessionState SessionContext I
 -- | 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
@@ -92,6 +93,7 @@ data SessionContext = SessionContext
   , requestMap :: MVar RequestMap
   , initRsp :: MVar InitializeResponse
   , config :: SessionConfig
+  , sessionCapabilities :: ClientCapabilities
   }
 
 class Monad m => HasReader r m where
@@ -170,10 +172,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 +186,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,10 +277,12 @@ updateState _ = return ()
 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
 
-    setSGR [SetColor Foreground Vivid Cyan]
+  shouldLog <- asks $ logMessages . config
+  liftIO $ when shouldLog $ do
+  
+    setSGR [SetColor Foreground Dull Cyan]
     putStrLn $ "--> " ++ B.unpack encoded
     setSGR [Reset]