diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for lsp-test +## 0.9.0.0 -- 2019-12-1 + +* Add `ignoreLogNotifications` config option +* Add ability to override `logStdErr` and `logMessages` config options with + the `LSP_TEST_LOG_STDERR` and `LOG_TEST_LOG_MESSAGES` environment variables +* Update for haskell-lsp-0.19.0.0 (@mpickering) + ## 0.8.2.0 -- 2019-11-17 * Expose `satisfyMaybe` (@cocreature) diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.8.2.0 +version: 0.9.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -13,7 +13,6 @@ license-file: LICENSE author: Luke Lau maintainer: luke_lau@icloud.com -stability: experimental bug-reports: https://github.com/bubba/lsp-test/issues copyright: 2019 Luke Lau category: Testing @@ -36,7 +35,7 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , haskell-lsp == 0.18.* + , haskell-lsp == 0.19.* , aeson , aeson-pretty , ansi-terminal @@ -79,7 +78,7 @@ build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp == 0.18.* + , haskell-lsp == 0.19.* , lsp-test , data-default , aeson diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -37,6 +37,7 @@ , module Language.Haskell.LSP.Test.Parsing -- * Utilities -- | Quick helper functions for common tasks. + -- ** Initialization , initializeResponse -- ** Documents @@ -109,6 +110,7 @@ import Language.Haskell.LSP.Test.Parsing import Language.Haskell.LSP.Test.Session import Language.Haskell.LSP.Test.Server +import System.Environment import System.IO import System.Directory import System.FilePath @@ -136,10 +138,12 @@ -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a -runSessionWithConfig config serverExe caps rootDir session = do +runSessionWithConfig config' serverExe caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir + config <- envOverrideConfig config' + let initializeParams = InitializeParams (Just pid) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) @@ -184,6 +188,17 @@ (RspShutdown _) -> return () _ -> listenServer serverOut context + -- | Check environment variables to override the config + envOverrideConfig :: SessionConfig -> IO SessionConfig + envOverrideConfig cfg = do + logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES" + logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR" + return $ cfg { logMessages = logMessages', logStdErr = logStdErr' } + where checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> lookupEnv s + convertVal "0" = False + convertVal _ = True + -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do @@ -452,7 +467,7 @@ fs <- vfsMap . vfs <$> get let ver = case fs Map.!? toNormalizedUri uri of - Just (VirtualFile v _) -> Just v + Just vf -> Just (virtualFileVersion vf) _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as B -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' -data SessionException = Timeout +data SessionException = Timeout (Maybe FromServerMessage) | NoContentLengthHeader | UnexpectedMessage String FromServerMessage | ReplayOutOfOrder FromServerMessage [FromServerMessage] @@ -24,12 +24,16 @@ instance Exception SessionException instance Show SessionException where - show Timeout = "Timed out waiting to receive a message from the server." + show (Timeout lastMsg) = + "Timed out waiting to receive a message from the server." ++ + case lastMsg of + Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg) + Nothing -> mempty show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ - "Last message received: " ++ show lastMsg + "Last message received:\n" ++ B.unpack (encodePretty lastMsg) show (ReplayOutOfOrder received expected) = let expected' = nub expected getJsonDiff = lines . B.unpack . encodePretty diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -91,15 +91,24 @@ -- | 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 -- ^ Redirect the server's stderr to this stdout, defaults to False. - , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False. + , logStdErr :: Bool + -- ^ Redirect the server's stderr to this stdout, defaults to False. + -- Can be overriden with @LSP_TEST_LOG_STDERR@. + , logMessages :: Bool + -- ^ Trace the messages sent and received to stdout, defaults to False. + -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@. , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing. + , ignoreLogNotifications :: Bool + -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and + -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False. + -- + -- @since 0.9.0.0 } -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. defaultConfig :: SessionConfig -defaultConfig = SessionConfig 60 False False True Nothing +defaultConfig = SessionConfig 60 False False True Nothing False instance Default SessionConfig where def = defaultConfig @@ -181,15 +190,20 @@ chanSource = do msg <- liftIO $ readChan (messageChan context) - yield msg + unless (ignoreLogNotifications (config context) && isLogNotification msg) $ + yield msg chanSource + isLogNotification (ServerMessage (NotShowMessage _)) = True + isLogNotification (ServerMessage (NotLogMessage _)) = True + isLogNotification _ = False + watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () watchdog = Conduit.awaitForever $ \msg -> do curId <- curTimeoutId <$> get case msg of ServerMessage sMsg -> yield sMsg - TimeoutMessage tId -> when (curId == tId) $ throw Timeout + TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. @@ -281,7 +295,7 @@ forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s - update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t + update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS in s { vfs = newVFS } @@ -290,7 +304,7 @@ ctx <- ask -- if its not open, open it - unless (toNormalizedUri uri `Map.member` (vfsMap oldVFS)) $ do + unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents @@ -361,4 +375,5 @@ | otherwise = Cyan showPretty = B.unpack . encodePretty + diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -91,7 +91,9 @@ getDocumentSymbols doc -- should now timeout skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest - in sesh `shouldThrow` (== Timeout) + isTimeout (Timeout _) = True + isTimeout _ = False + in sesh `shouldThrow` isTimeout describe "SessionException" $ do @@ -330,6 +332,12 @@ let pred (NotLogMessage _) = True pred _ = False void $ satisfy pred + + describe "ignoreLogNotifications" $ + it "works" $ + runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do + openDoc "Format.hs" "haskell" + void publishDiagnosticsNotification mkRange sl sc el ec = Range (Position sl sc) (Position el ec)