diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 2.9.0.1 +version: 2.10.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -43,8 +43,8 @@ , directory , extra , filepath - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp , lsp-test ^>=0.17 diff --git a/src/Development/IDE/Test.hs b/src/Development/IDE/Test.hs --- a/src/Development/IDE/Test.hs +++ b/src/Development/IDE/Test.hs @@ -14,6 +14,8 @@ , diagnostic , expectDiagnostics , expectDiagnosticsWithTags + , ExpectedDiagnostic + , ExpectedDiagnosticWithTag , expectNoMoreDiagnostics , expectMessages , expectCurrentDiagnostics @@ -63,10 +65,13 @@ import System.Time.Extra import Test.Tasty.HUnit +expectedDiagnosticWithNothing :: ExpectedDiagnostic -> ExpectedDiagnosticWithTag +expectedDiagnosticWithNothing (ds, c, t, code) = (ds, c, t, code, Nothing) + requireDiagnosticM :: (Foldable f, Show (f Diagnostic), HasCallStack) => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> ExpectedDiagnosticWithTag -> Assertion requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of Nothing -> pure () @@ -114,25 +119,25 @@ -- -- Rather than trying to assert the absence of diagnostics, introduce an -- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics :: HasCallStack => [(FilePath, [ExpectedDiagnostic])] -> Session () expectDiagnostics = expectDiagnosticsWithTags - . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + . map (second (map expectedDiagnosticWithNothing)) unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) -expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags :: HasCallStack => [(String, [ExpectedDiagnosticWithTag])] -> Session () expectDiagnosticsWithTags expected = do - let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + let toSessionPath = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) toSessionPath expected expectDiagnosticsWithTags' next expected' expectDiagnosticsWithTags' :: (HasCallStack, MonadIO m) => m (Uri, [Diagnostic]) -> - Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> + Map.Map NormalizedUri [ExpectedDiagnosticWithTag] -> m () expectDiagnosticsWithTags' next m | null m = do (_,actual) <- next @@ -170,14 +175,14 @@ <> show actual go $ Map.delete canonUri m -expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> Session () expectCurrentDiagnostics doc expected = do diags <- getCurrentDiagnostics doc checkDiagnosticsForDoc doc expected diags -checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do - let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected) + let expected' = Map.singleton nuri (map expectedDiagnosticWithNothing expected) nuri = toNormalizedUri _uri expectDiagnosticsWithTags' (return (_uri, obtained)) expected' diff --git a/src/Development/IDE/Test/Diagnostic.hs b/src/Development/IDE/Test/Diagnostic.hs --- a/src/Development/IDE/Test/Diagnostic.hs +++ b/src/Development/IDE/Test/Diagnostic.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} module Development.IDE.Test.Diagnostic where import Control.Lens ((^.)) import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import GHC.Stack (HasCallStack) import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Types @@ -14,12 +16,41 @@ type ErrorMsg = String + +-- | Expected diagnostics have the following components: +-- +-- 1. severity +-- 2. cursor (line and column numbers) +-- 3. infix of the message +-- 4. code (e.g. GHC-87543) +type ExpectedDiagnostic = + ( DiagnosticSeverity + , Cursor + , T.Text + , Maybe T.Text + ) + +-- | Expected diagnostics with a tag have the following components: +-- +-- 1. severity +-- 2. cursor (line and column numbers) +-- 3. infix of the message +-- 4. code (e.g. GHC-87543) +-- 5. tag (unnecessary or deprecated) +type ExpectedDiagnosticWithTag = + ( DiagnosticSeverity + , Cursor + , T.Text + , Maybe T.Text + , Maybe DiagnosticTag + ) + requireDiagnostic :: (Foldable f, Show (f Diagnostic), HasCallStack) => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> ExpectedDiagnosticWithTag -> Maybe ErrorMsg -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, mbExpectedCode, expectedTag) | any match actuals = Nothing | otherwise = Just $ "Could not find " <> show expected <> @@ -32,6 +63,15 @@ && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` standardizeQuotes (T.toLower $ d ^. message) && hasTag expectedTag (d ^. tags) + && codeMatches d + + codeMatches d + | ghcVersion >= GHC96 = + case (mbExpectedCode, _code d) of + (Nothing, _) -> True + (Just expectedCode, Nothing) -> False + (Just expectedCode, Just actualCode) -> InR expectedCode == actualCode + | otherwise = True hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool hasTag Nothing _ = True diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -39,6 +39,10 @@ -- * Helpful re-exports PluginDescriptor, IdeState, + -- * Helpers for expected test case failuers + BrokenBehavior(..), + ExpectBroken(..), + unCurrent, -- * Assertion helper functions waitForProgressDone, waitForAllProgressDone, @@ -61,7 +65,9 @@ WithPriority(..), Recorder, Priority(..), - TestConfig(..), + captureKickDiagnostics, + kick, + TestConfig(..) ) where @@ -69,6 +75,7 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe +import Control.Lens ((^.)) import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) @@ -80,7 +87,7 @@ import Data.ByteString.Lazy (ByteString) import Data.Default (Default, def) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -114,6 +121,7 @@ pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types hiding (Null) @@ -162,6 +170,15 @@ LogCleanup -> "Cleaned up temporary directory" LogNoCleanup -> "No cleanup of temporary directory" +data BrokenBehavior = Current | Ideal + +data ExpectBroken (k :: BrokenBehavior) a where + BrokenCurrent :: a -> ExpectBroken 'Current a + BrokenIdeal :: a -> ExpectBroken 'Ideal a + +unCurrent :: ExpectBroken 'Current a -> a +unCurrent (BrokenCurrent a) = a + -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -231,14 +248,14 @@ :: Pretty b => TestConfig b -> TestName - -> FilePath + -> VirtualFileTree -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithTestConfig config title testDataDir path desc ext act = - goldenGitDiff title (testDataDir path <.> desc <.> ext) +goldenWithTestConfig config title tree path desc ext act = + goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) $ runSessionWithTestConfig config $ const $ TL.encodeUtf8 . TL.fromStrict <$> do @@ -869,6 +886,17 @@ -- requests! skipManyTill anyMessage (void configurationRequest) +captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic] +captureKickDiagnostics start done = do + _ <- skipManyTill anyMessage start + messages <- manyTill anyMessage done + pure $ concat $ mapMaybe diagnostics messages + where + diagnostics :: FromServerMessage' a -> Maybe [Diagnostic] + diagnostics = \msg -> case msg of + FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics) + _ -> Nothing + waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone @@ -880,6 +908,7 @@ nonTrivialKickStart :: Session () nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null + kick :: KnownSymbol k => Proxy k -> Session [FilePath] kick proxyMsg = do diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs --- a/src/Test/Hls/Util.hs +++ b/src/Test/Hls/Util.hs @@ -7,6 +7,7 @@ ( -- * Test Capabilities codeActionResolveCaps , codeActionNoResolveCaps + , codeActionNoInlayHintsCaps , codeActionSupportCaps , expectCodeAction -- * Environment specifications @@ -35,6 +36,7 @@ , inspectCodeAction , inspectCommand , inspectDiagnostic + , inspectDiagnosticAny , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -107,6 +109,12 @@ codeActionNoResolveCaps = Test.fullLatestClientCaps & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False + +codeActionNoInlayHintsCaps :: ClientCapabilities +codeActionNoInlayHintsCaps = Test.fullLatestClientCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False + & (L.textDocument . _Just . L.inlayHint) .~ Nothing -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- --------------------------------------------------------------------- @@ -239,6 +247,10 @@ inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" + +inspectDiagnosticAny :: [Diagnostic] -> [T.Text] -> IO Diagnostic +inspectDiagnosticAny diags s = onMatch diags (\ca -> any (`T.isInfixOf` (ca ^. L.message)) s) err + where err = "expected diagnostic matching one of'" ++ show s ++ "' but did not find one" expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () expectDiagnostic diags s = void $ inspectDiagnostic diags s