hls-test-utils 2.9.0.1 → 2.10.0.0

raw patch · 5 files changed

+106/−20 lines, 5 filesdep ~ghcidedep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghcide, hls-plugin-api

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +3/−3
• src/Development/IDE/Test.hs +15/−10
• src/Development/IDE/Test/Diagnostic.hs +42/−2
• src/Test/Hls.hs +34/−5
• src/Test/Hls/Util.hs +12/−0

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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

@@ -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' 

@@ -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

@@ -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

@@ -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