X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=1fee2be798f4ebdf504667556d5aa0523bd3e280;hb=cdb1ba7038c32bac71a3bc783effc1e07049a985;hp=1dee298a933b0f93ff203f152dcbff7c4fafe8cb;hpb=42757e7fe53223f3bdd81180a682faf72761afe3;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 1dee298..1fee2be 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
@@ -35,6 +38,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
@@ -71,14 +75,18 @@ 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 -- ^ 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.
   }
 
+-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
+defaultConfig :: SessionConfig
+defaultConfig = SessionConfig 60 False True 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
@@ -156,7 +165,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 +178,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 +192,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
@@ -208,7 +217,6 @@ updateState (NotPublishDiagnostics n) = do
 
 updateState (ReqApplyWorkspaceEdit r) = do
 
-
   allChangeParams <- case r ^. params . edit . documentChanges of
     Just (List cs) -> do
       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
@@ -275,14 +283,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
@@ -300,3 +302,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