Add logColor config option

diff --git a/example/Main.hs b/example/Main.hs
index a6bafe97d99edcaf499571ba97bcf100befdfbf3..7ee3f92cd414db960a5b14d98d3804d1745c6995 100644 (file)
--- a/example/Main.hs
+++ b/example/Main.hs
@@ -3,7 +3,7 @@ import Control.Monad.IO.Class
 import Language.Haskell.LSP.Test
 import Language.Haskell.LSP.Types
 
-main = runSession "hie --lsp" fullCaps "test/recordings/renamePass" $ do
+main = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
   docItem <- openDoc "Desktop/simple.hs" "haskell"
   
   -- Use your favourite favourite combinators.

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index aeae56bee28fa6ec0684116a4080bd7cd7a302c6..568ead8ff592846fbc77e0e41adbaa9e08a2064b 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -21,6 +21,7 @@ module Language.Haskell.LSP.Test
   , runSessionWithConfig
   , Session
   , SessionConfig(..)
+  , defaultConfig
   , SessionException(..)
   , anySessionException
   , withTimeout

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 2936b31347f9db69ecf4b1a3951c552336953cfb..b6830357db5b32144f9629d900d5f42b91f64196 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -10,7 +10,6 @@ import Control.Lens
 import Control.Monad.IO.Class
 import Control.Monad
 import Data.Aeson
-import Data.Aeson.Encode.Pretty
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Conduit.Parser
 import Data.Maybe
@@ -20,7 +19,6 @@ import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types as LSP hiding (error)
 import Language.Haskell.LSP.Test.Messages
 import Language.Haskell.LSP.Test.Session
-import System.Console.ANSI
 
 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
 satisfy pred = do
@@ -43,11 +41,7 @@ satisfy pred = do
 
   if pred x
     then do
-      shouldLog <- asks $ logMessages . config
-      liftIO $ when shouldLog $ do
-        setSGR [SetColor Foreground Dull Magenta]
-        putStrLn $ "<-- " ++ B.unpack (encodeMsgPretty x)
-        setSGR [Reset]
+      logMsg LogServer x
       return x
     else empty
 
@@ -88,9 +82,6 @@ castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
 encodeMsg :: FromServerMessage -> B.ByteString
 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
 
-encodeMsgPretty :: FromServerMessage -> B.ByteString
-encodeMsgPretty = encodePretty . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
-
 -- | Matches if the message is a log message notification or a show message notification/request.
 loggingNotification :: Session FromServerMessage
 loggingNotification = named "Logging notification" $ satisfy shouldSkip

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index a58496d5234dff41854b0f5baba401658daeffc7..39a3ed29bd4b44d406d4cc288eca49fa3540faaf 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -6,6 +6,7 @@
 module Language.Haskell.LSP.Test.Session
   ( Session
   , SessionConfig(..)
+  , defaultConfig
   , SessionMessage(..)
   , SessionContext(..)
   , SessionState(..)
@@ -19,6 +20,8 @@ module Language.Haskell.LSP.Test.Session
   , sendMessage
   , updateState
   , withTimeout
+  , logMsg
+  , LogMsgType(..)
   )
 
 where
@@ -72,14 +75,17 @@ type Session = ParserStateReader FromServerMessage SessionState SessionContext I
 
 -- | Stuff you can configure for a 'Session'.
 data SessionConfig = SessionConfig
-  {
-    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.
+  { 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 True.
+  , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
   }
 
+defaultConfig :: SessionConfig
+defaultConfig = SessionConfig 60 False True True
+
 instance Default SessionConfig where
-  def = SessionConfig 60 False True
+  def = defaultConfig
 
 data SessionMessage = ServerMessage FromServerMessage
                     | TimeoutMessage Int
@@ -158,7 +164,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
@@ -277,16 +282,8 @@ updateState _ = return ()
 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
 sendMessage msg = do
   h <- serverIn <$> ask
-  let encoded = encodePretty msg
-
-  shouldLog <- asks $ logMessages . config
-  liftIO $ when shouldLog $ do
-  
-    setSGR [SetColor Foreground Dull 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
@@ -304,3 +301,36 @@ withTimeout duration f = do
                      overridingTimeout = False 
                    }
   return res
+
+-- logClientMsg :: (MonadIO m, HasReader SessionContext m)
+--              => FromClientMessage -> m ()
+-- logClientMsg = logMsg True
+
+-- logServerMsg :: (MonadIO m, HasReader SessionContext m)
+--              => FromServerMessage -> m ()
+-- logServerMsg = logMsg False
+
+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 :: ToJSON a => a -> String
+showPretty = B.unpack . encodePretty