From f0d93bbe47d55ab650909e0487c65c1048f1bb9a Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 31 Jul 2018 00:01:05 +0100 Subject: [PATCH] Add logColor config option --- example/Main.hs | 2 +- src/Language/Haskell/LSP/Test.hs | 1 + src/Language/Haskell/LSP/Test/Parsing.hs | 11 +---- src/Language/Haskell/LSP/Test/Session.hs | 62 ++++++++++++++++++------ 4 files changed, 49 insertions(+), 27 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index a6bafe9..7ee3f92 100644 --- 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 aeae56b..568ead8 100644 --- 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 2936b31..b683035 100644 --- 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 a58496d..39a3ed2 100644 --- 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 -- 2.30.2