From 407511ec43afd26bc60b3a1c185f26c14d899700 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 15 Dec 2020 23:14:21 +0100 Subject: [PATCH 1/3] Add test utilities * expectNoMoreDiagnostics, adapted from ghcide * add knownBroken and ignore by ghc version --- haskell-language-server.cabal | 2 +- test/utils/Test/Hls/Util.hs | 88 ++++++++++++++++++++++++++++++----- 2 files changed, 78 insertions(+), 12 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 70873b6688..c1d2e63e53 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -200,6 +200,7 @@ common hls-test-utils , lens , lsp-test >=0.11.0.6 , stm + , tasty-expected-failure , tasty-hunit , temporary , transformers @@ -227,7 +228,6 @@ test-suite func-test , lens , tasty , tasty-ant-xml >=1.1.6 - , tasty-expected-failure , tasty-golden , tasty-rerun diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 69a338c9b7..cef09341f6 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -5,6 +5,7 @@ module Test.Hls.Util , dummyLspFuncs , expectCodeAction , expectDiagnostic + , expectNoMoreDiagnostics , flushStackEnvironment , fromAction , fromCommand @@ -13,22 +14,26 @@ module Test.Hls.Util , hlsCommand , hlsCommandExamplePlugin , hlsCommandVomit + , ignoreForGhcVersions , inspectCodeAction , inspectCommand , inspectDiagnostic + , knownBrokenForGhcVersions , logConfig , logFilePath , noLogConfig , setupBuildToolFiles , waitForDiagnosticsFrom , waitForDiagnosticsFromSource + , waitForDiagnosticsFromSourceWithTimeout , withFileLogging , withCurrentDirectoryInTmp ) where import Control.Monad -import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class +import Control.Applicative.Combinators (skipManyTill, (<|>)) import Control.Lens ((^.)) import Data.Default import Data.List (intercalate) @@ -36,27 +41,32 @@ import Data.List.Extra (find) import Data.Maybe import qualified Data.Text as T import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Test as T +import qualified Language.Haskell.LSP.Test as Test import qualified Language.Haskell.LSP.Types.Lens as L import qualified Language.Haskell.LSP.Types.Capabilities as C import System.Directory import System.Environment +import System.Time.Extra (Seconds, sleep) import System.FilePath import qualified System.Log.Logger as L import System.IO.Temp import System.IO.Unsafe import Test.Hspec.Runner -import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Formatters hiding (Seconds) +import Test.Tasty (TestTree) +import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) +import Test.Tasty.HUnit (assertFailure) import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) -noLogConfig :: T.SessionConfig -noLogConfig = T.defaultConfig { T.logMessages = False } +noLogConfig :: Test.SessionConfig +noLogConfig = Test.defaultConfig { Test.logMessages = False } -logConfig :: T.SessionConfig -logConfig = T.defaultConfig { T.logMessages = True } +logConfig :: Test.SessionConfig +logConfig = Test.defaultConfig { Test.logMessages = True } codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } @@ -127,6 +137,16 @@ ghcVersion = GHC86 ghcVersion = GHC84 #endif +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions vers reason + | ghcVersion `elem` vers = expectFailBecause reason + | otherwise = id + +ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +ignoreForGhcVersions vers reason + | ghcVersion `elem` vers = ignoreTestBecause reason + | otherwise = id + logFilePath :: String logFilePath = "hls-" ++ show ghcVersion ++ ".log" @@ -330,17 +350,17 @@ inspectCommand cars s = fromCommand <$> onMatch cars predicate err predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" -waitForDiagnosticsFrom :: TextDocumentIdentifier -> T.Session [Diagnostic] +waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill T.anyMessage T.message :: T.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc else return diags -waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> T.Session [Diagnostic] +waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic] waitForDiagnosticsFromSource doc src = do - diagsNot <- skipManyTill T.anyMessage T.message :: T.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. L.params . L.diagnostics let res = filter matches diags if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res @@ -349,3 +369,49 @@ waitForDiagnosticsFromSource doc src = do where matches :: Diagnostic -> Bool matches d = d ^. L.source == Just (T.pack src) + +-- | wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +expectNoMoreDiagnostics :: Seconds -> TextDocumentIdentifier -> String -> Test.Session () +expectNoMoreDiagnostics timeout doc src = do + diags <- waitForDiagnosticsFromSourceWithTimeout timeout doc src + unless (null diags) $ + liftIO $ assertFailure $ + "Got unexpected diagnostics for " <> show (doc ^. L.uri) <> + " got " <> show diags + +-- | wait for @timeout@ seconds and return diagnostics for the given @document and @source. +-- If timeout is 0 it will wait until the session timeout +waitForDiagnosticsFromSourceWithTimeout :: Seconds -> TextDocumentIdentifier -> String -> Test.Session [Diagnostic] +waitForDiagnosticsFromSourceWithTimeout timeout document source = do + when (timeout > 0) $ do + -- Give any further diagnostic messages time to arrive. + liftIO $ sleep timeout + -- Send a dummy message to provoke a response from the server. + -- This guarantees that we have at least one message to + -- process, so message won't block or timeout. + void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + handleMessages + where + matches :: Diagnostic -> Bool + matches d = d ^. L.source == Just (T.pack source) + + handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers + handleDiagnostic = do + diagsNot <- Test.message :: Test.Session PublishDiagnosticsNotification + let fileUri = diagsNot ^. L.params . L.uri + (List diags) = diagsNot ^. L.params . L.diagnostics + res = filter matches diags + if fileUri == document ^. L.uri && not (null res) + then return diags else handleMessages + handleCustomMethodResponse = + -- the CustomClientMethod triggers a RspCustomServer + -- handle that and then exit + void (Test.satisfyMaybe responseForNonExistentMethod) >> return [] + + responseForNonExistentMethod notif + | NotLogMessage logMsg <- notif, + "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif + | otherwise = Nothing + + ignoreOthers = void Test.anyMessage >> handleMessages From 146c104a75b006e8b7fc3184d518a90c239951de Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 15 Dec 2020 23:33:49 +0100 Subject: [PATCH 2/3] hlint tests for cpp, extensions and ignore hints * for issues #554, #590 and #838 --- test/functional/FunctionalCodeAction.hs | 110 +++++++++++++----- test/testdata/hlint/ApplyRefact1.hs | 5 + test/testdata/hlint/ApplyRefact3.hs | 8 ++ test/testdata/hlint/ApplyRefact4.hs | 5 + test/testdata/hlint/ApplyRefact5.hs | 7 ++ test/testdata/hlint/cpp/ApplyRefact2.hs | 9 ++ test/testdata/hlint/cpp/ApplyRefact3.hs | 7 ++ test/testdata/hlint/cpp/hie.yaml | 7 ++ test/testdata/hlint/cpp/test.h | 1 + test/testdata/hlint/hie.yaml | 6 + test/testdata/hlint/ignore/.hlint.yaml | 2 + test/testdata/hlint/ignore/ApplyRefact.hs | 5 + test/testdata/hlint/ignore/hie.yaml | 4 + .../testdata/hlint/lambdacase/ApplyRefact1.hs | 4 + test/testdata/hlint/lambdacase/hie.yaml | 5 + 15 files changed, 157 insertions(+), 28 deletions(-) create mode 100644 test/testdata/hlint/ApplyRefact1.hs create mode 100644 test/testdata/hlint/ApplyRefact3.hs create mode 100644 test/testdata/hlint/ApplyRefact4.hs create mode 100644 test/testdata/hlint/ApplyRefact5.hs create mode 100644 test/testdata/hlint/cpp/ApplyRefact2.hs create mode 100644 test/testdata/hlint/cpp/ApplyRefact3.hs create mode 100644 test/testdata/hlint/cpp/hie.yaml create mode 100644 test/testdata/hlint/cpp/test.h create mode 100644 test/testdata/hlint/ignore/.hlint.yaml create mode 100644 test/testdata/hlint/ignore/ApplyRefact.hs create mode 100644 test/testdata/hlint/ignore/hie.yaml create mode 100644 test/testdata/hlint/lambdacase/ApplyRefact1.hs create mode 100644 test/testdata/hlint/lambdacase/hie.yaml diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 9e7b1149f4..f15718b35b 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -20,8 +20,9 @@ import qualified Language.Haskell.LSP.Types.Lens as L import qualified Language.Haskell.LSP.Types.Capabilities as C import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) import Test.Tasty.HUnit +import System.FilePath (()) {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -41,7 +42,7 @@ tests = testGroup "code actions" [ hlintTests :: TestTree hlintTests = testGroup "hlint suggestions" [ - testCase "provides 3.8 code actions including apply all" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" @@ -73,55 +74,108 @@ hlintTests = testGroup "hlint suggestions" [ _ <- waitForDiagnosticsFromSource doc "hlint" cars <- getAllCodeActions doc - etaReduce <- liftIO $ inspectCommand cars ["Apply hint: Eta reduce"] + etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] executeCommand etaReduce contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo = id\n" - , testCase "changing configuration enables or disables hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" - diags <- waitForDiagnosticsFromSource doc "hlint" - - liftIO $ length diags > 0 @? "There are hlint diagnostics" + testHlintDiagnostics doc let config' = def { hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc - liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics" - - , testCase "changing document contents updates hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do - doc <- openDoc "ApplyRefact2.hs" "haskell" - diags <- waitForDiagnosticsSource "hlint" - - liftIO $ length diags @?= 2 -- "Eta Reduce" and "Redundant Id" - - let change = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "x" + liftIO $ noHlintDiagnostics diags' - changeDoc doc [change] + , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ + testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do + doc <- openDoc "ApplyRefact3.hs" "haskell" + testHlintDiagnostics doc - diags' <- waitForDiagnostics + , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ + testCase "hlint diagnostics works with CPP via language pragma (#554)" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact3.hs" "haskell" + testHlintDiagnostics doc - liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics" + , testCase "hlint diagnostics works with CPP via -XCPP argument and flag via #include header (#554)" $ runHlintSession "cpp" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + , knownBrokenForGhcVersions [GHC88, GHC86] "apply-refact doesn't take in account the -X argument" $ + testCase "apply-refact works with LambdaCase via ghc -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do + testRefactor "ApplyRefact1.hs" "Redundant bracket" + expectedLambdaCase + + , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do + testRefactor "ApplyRefact1.hs" "Redundant bracket" + ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do + testRefactor "ApplyRefact3.hs" "Redundant bracket" + expectedCPP + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do + testRefactor "ApplyRefact3.hs" "Redundant bracket" + ("{-# LANGUAGE CPP #-}" : expectedCPP) + + , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do + doc <- openDoc "ApplyRefact.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact4.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , knownBrokenForGhcVersions [GHC810] "hlint plugin doesn't honour HLINT annotations (#838)" $ + testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact5.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + ] + where + runHlintSession subdir = runSession hlsCommand fullCaps $ "test/testdata/hlint" subdir - let change' = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "id x" + noHlintDiagnostics :: [Diagnostic] -> Assertion + noHlintDiagnostics diags = + Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" - changeDoc doc [change'] + testHlintDiagnostics doc = do + diags <- waitForDiagnosticsFromSource doc "hlint" + liftIO $ length diags > 0 @? "There are hlint diagnostics" - diags'' <- waitForDiagnosticsFromSource doc "hlint" + testRefactor file caTitle expected = do + doc <- openDoc file "haskell" + testHlintDiagnostics doc - liftIO $ length diags'' @?= 2 - ] + cas <- map fromAction <$> getAllCodeActions doc + let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas + liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action") + + executeCodeAction (fromJust ca) + + contents <- getDocumentEdit doc + liftIO $ contents @?= T.unlines expected + + expectedLambdaCase = [ "module ApplyRefact1 where", "" + , "f = \\case \"true\" -> True" + , " _ -> False" + ] + expectedCPP = [ "module ApplyRefact3 where", "" + , "#ifdef FLAG" + , "f = 1" + , "#else" + , "g = 2" + , "#endif", "" + ] renameTests :: TestTree renameTests = testGroup "rename suggestions" [ diff --git a/test/testdata/hlint/ApplyRefact1.hs b/test/testdata/hlint/ApplyRefact1.hs new file mode 100644 index 0000000000..8ff4c6f00f --- /dev/null +++ b/test/testdata/hlint/ApplyRefact1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +module ApplyRefact1 where + +f = \case "true" -> (True) + _ -> False diff --git a/test/testdata/hlint/ApplyRefact3.hs b/test/testdata/hlint/ApplyRefact3.hs new file mode 100644 index 0000000000..81e307b2d5 --- /dev/null +++ b/test/testdata/hlint/ApplyRefact3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module ApplyRefact3 where + +#ifdef FLAG +f = (1) +#else +g = 2 +#endif diff --git a/test/testdata/hlint/ApplyRefact4.hs b/test/testdata/hlint/ApplyRefact4.hs new file mode 100644 index 0000000000..8752966daa --- /dev/null +++ b/test/testdata/hlint/ApplyRefact4.hs @@ -0,0 +1,5 @@ +module ApplyRefact4 where + +{-# ANN module "HLint: ignore Redundant bracket" #-} +f = (1) + diff --git a/test/testdata/hlint/ApplyRefact5.hs b/test/testdata/hlint/ApplyRefact5.hs new file mode 100644 index 0000000000..1507bba739 --- /dev/null +++ b/test/testdata/hlint/ApplyRefact5.hs @@ -0,0 +1,7 @@ +module ApplyRefact5 where + +{- HLINT ignore "Redundant bracket" -} +f = (1) + +{-# HLINT ignore "Use camelCase" #-} +camel_case = undefined diff --git a/test/testdata/hlint/cpp/ApplyRefact2.hs b/test/testdata/hlint/cpp/ApplyRefact2.hs new file mode 100644 index 0000000000..b25d6f77af --- /dev/null +++ b/test/testdata/hlint/cpp/ApplyRefact2.hs @@ -0,0 +1,9 @@ +module ApplyRefact2 where + +#include "test.h" + +#ifdef TEST +f = (1) +#else +f = 1 +#endif diff --git a/test/testdata/hlint/cpp/ApplyRefact3.hs b/test/testdata/hlint/cpp/ApplyRefact3.hs new file mode 100644 index 0000000000..cb2cc70c60 --- /dev/null +++ b/test/testdata/hlint/cpp/ApplyRefact3.hs @@ -0,0 +1,7 @@ +module ApplyRefact3 where + +#ifdef FLAG +f = (1) +#else +g = 2 +#endif diff --git a/test/testdata/hlint/cpp/hie.yaml b/test/testdata/hlint/cpp/hie.yaml new file mode 100644 index 0000000000..a30ec3673d --- /dev/null +++ b/test/testdata/hlint/cpp/hie.yaml @@ -0,0 +1,7 @@ +cradle: + direct: + arguments: + - "-XCPP" + - "-DFLAG" + - "ApplyRefact3" + - "ApplyRefact2" diff --git a/test/testdata/hlint/cpp/test.h b/test/testdata/hlint/cpp/test.h new file mode 100644 index 0000000000..9fca16e358 --- /dev/null +++ b/test/testdata/hlint/cpp/test.h @@ -0,0 +1 @@ +#define TEST diff --git a/test/testdata/hlint/hie.yaml b/test/testdata/hlint/hie.yaml index c3a48bbd34..08c71a6ee2 100644 --- a/test/testdata/hlint/hie.yaml +++ b/test/testdata/hlint/hie.yaml @@ -1,4 +1,10 @@ cradle: direct: arguments: + - "-DFLAG" + - "-Wno-unrecognised-pragmas" + - "ApplyRefact1" - "ApplyRefact2" + - "ApplyRefact3" + - "ApplyRefact4" + - "ApplyRefact5" diff --git a/test/testdata/hlint/ignore/.hlint.yaml b/test/testdata/hlint/ignore/.hlint.yaml new file mode 100644 index 0000000000..f76f860aa9 --- /dev/null +++ b/test/testdata/hlint/ignore/.hlint.yaml @@ -0,0 +1,2 @@ +- ignore: { name: "Redundant bracket" } +- ignore: { name: "Use camelCase" } diff --git a/test/testdata/hlint/ignore/ApplyRefact.hs b/test/testdata/hlint/ignore/ApplyRefact.hs new file mode 100644 index 0000000000..50ad6d05f5 --- /dev/null +++ b/test/testdata/hlint/ignore/ApplyRefact.hs @@ -0,0 +1,5 @@ +module ApplyRefact where + +f = (1) + +camel_case = undefined diff --git a/test/testdata/hlint/ignore/hie.yaml b/test/testdata/hlint/ignore/hie.yaml new file mode 100644 index 0000000000..2a9b3ee8dc --- /dev/null +++ b/test/testdata/hlint/ignore/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "ApplyRefact" diff --git a/test/testdata/hlint/lambdacase/ApplyRefact1.hs b/test/testdata/hlint/lambdacase/ApplyRefact1.hs new file mode 100644 index 0000000000..b23fe74b05 --- /dev/null +++ b/test/testdata/hlint/lambdacase/ApplyRefact1.hs @@ -0,0 +1,4 @@ +module ApplyRefact1 where + +f = \case "true" -> (True) + _ -> False diff --git a/test/testdata/hlint/lambdacase/hie.yaml b/test/testdata/hlint/lambdacase/hie.yaml new file mode 100644 index 0000000000..645c4b4927 --- /dev/null +++ b/test/testdata/hlint/lambdacase/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "-XLambdaCase" + - "ApplyRefact1" From 4fa01295cfd71db6bfda98d847e2e5a972693e48 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 16 Dec 2020 13:06:09 +0100 Subject: [PATCH 3/3] Emit error assertion when session timeout --- test/functional/FunctionalCodeAction.hs | 4 +++- test/utils/Test/Hls/Util.hs | 10 +++++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f15718b35b..9d0a8b453f 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -142,7 +142,9 @@ hlintTests = testGroup "hlint suggestions" [ expectNoMoreDiagnostics 3 doc "hlint" ] where - runHlintSession subdir = runSession hlsCommand fullCaps $ "test/testdata/hlint" subdir + runHlintSession :: FilePath -> Session a -> IO a + runHlintSession subdir = + failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index cef09341f6..3d69fa4157 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns #-} +{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses #-} module Test.Hls.Util ( codeActionSupportCaps @@ -6,6 +6,7 @@ module Test.Hls.Util , expectCodeAction , expectDiagnostic , expectNoMoreDiagnostics + , failIfSessionTimeout , flushStackEnvironment , fromAction , fromCommand @@ -31,6 +32,7 @@ module Test.Hls.Util ) where +import Control.Exception (throwIO, catch) import Control.Monad import Control.Monad.IO.Class import Control.Applicative.Combinators (skipManyTill, (<|>)) @@ -415,3 +417,9 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do | otherwise = Nothing ignoreOthers = void Test.anyMessage >> handleMessages + +failIfSessionTimeout :: IO a -> IO a +failIfSessionTimeout action = action `catch` errorHandler + where errorHandler :: Test.SessionException -> IO a + errorHandler e@(Test.Timeout _) = assertFailure $ show e + errorHandler e = throwIO e