Migrate FindDefinitionAndHoverTests and HighlightTests part of #4173 and fix HighlightTests (#4202)

soulomoon · web-flow · commit 75cb0b9ab811 · 2024-05-02T16:02:16.000Z
* migrate FindDefinitionAndHoverTests

* migrate highlighttests

* fix highlight
diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs
@@ -38,6 +38,7 @@ module Development.IDE.GHC.Compat(
     mkFastStringByteString,
     nodeInfo',
     getNodeIds,
+    getSourceNodeIds,
     sourceNodeInfo,
     generatedNodeInfo,
     simpleNodeInfoCompat,
@@ -471,7 +472,9 @@ isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False
 isQualifiedImport ImportDecl{}                              = True
 isQualifiedImport _                                         = False
 
-
+-- | Like getNodeIds but with generated node removed
+getSourceNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)
+getSourceNodeIds = Map.foldl' combineNodeIds Map.empty . Map.filterWithKey (\k _ -> k == SourceInfo) . getSourcedNodeInfo . sourcedNodeInfo
 
 getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)
 getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo
diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs
@@ -56,6 +56,7 @@ import           Data.List                            (isSuffixOf)
 import           Data.List.Extra                      (dropEnd1, nubOrd)
 
 import           Data.Version                         (showVersion)
+import           Development.IDE.GHC.Compat           (getSourceNodeIds)
 import           Development.IDE.Types.Shake          (WithHieDb)
 import           HieDb                                hiding (pointCommand,
                                                        withHieDb)
@@ -167,7 +168,7 @@ documentHighlight hf rf pos = pure highlights
   where
     -- We don't want to show document highlights for evidence variables, which are supposed to be invisible
     notEvidence = not . any isEvidenceContext . identInfo
-    ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds)
+    ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getSourceNodeIds)
     highlights = do
       n <- ns
       ref <- fromMaybe [] (M.lookup (Right n) rf)
diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs
@@ -1,5 +1,6 @@
 module BootTests (tests) where
 
+import           Config                          (checkDefs, mkR)
 import           Control.Applicative.Combinators
 import           Control.Monad
 import           Control.Monad.IO.Class          (liftIO)
diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs
@@ -2,11 +2,15 @@
 
 module Config where
 
-import           Ide.Types           (defaultPluginDescriptor)
-import           System.FilePath     ((</>))
+import           Data.Foldable               (traverse_)
+import qualified Data.Text                   as T
+import           Development.IDE.Test        (canonicalizeUri)
+import           Ide.Types                   (defaultPluginDescriptor)
+import           Language.LSP.Protocol.Types (Null (..))
+import           System.FilePath             ((</>))
 import           Test.Hls
-import qualified Test.Hls.FileSystem as FS
-import           Test.Hls.FileSystem (FileSystem)
+import qualified Test.Hls.FileSystem         as FS
+import           Test.Hls.FileSystem         (FileSystem)
 
 testDataDir :: FilePath
 testDataDir = "ghcide" </> "test" </> "data"
@@ -24,6 +28,12 @@ runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin
 runWithDummyPlugin' ::  FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a
 runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin
 
+runWithDummyPluginAndCap :: ClientCapabilities -> Session () -> IO ()
+runWithDummyPluginAndCap cap = runSessionWithServerAndCapsInTmpDir def dummyPlugin cap (mkIdeTestFs [])
+
+testWithDummyPluginAndCap :: String -> ClientCapabilities -> Session () -> TestTree
+testWithDummyPluginAndCap caseName cap = testCase caseName . runWithDummyPluginAndCap cap
+
 -- testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree
 testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree
 testWithDummyPlugin caseName vfs = testCase caseName . runWithDummyPlugin vfs
@@ -50,3 +60,57 @@ testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFil
 
 pattern R :: UInt -> UInt -> UInt -> UInt -> Range
 pattern R x y x' y' = Range (Position x y) (Position x' y')
+
+data Expect
+  = ExpectRange Range -- Both gotoDef and hover should report this range
+  | ExpectLocation Location
+--  | ExpectDefRange Range -- Only gotoDef should report this range
+  | ExpectHoverRange Range -- Only hover should report this range
+  | ExpectHoverText [T.Text] -- the hover message must contain these snippets
+  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets
+  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern
+  | ExpectExternFail -- definition lookup in other file expected to fail
+  | ExpectNoDefinitions
+  | ExpectNoHover
+--  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
+  deriving Eq
+
+mkR :: UInt -> UInt -> UInt -> UInt -> Expect
+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
+
+mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect
+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
+
+
+checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()
+checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where
+  check (ExpectRange expectedRange) = do
+    def <- assertOneDefinitionFound defs
+    assertRangeCorrect def expectedRange
+  check (ExpectLocation expectedLocation) = do
+    def <- assertOneDefinitionFound defs
+    liftIO $ do
+      canonActualLoc <- canonicalizeLocation def
+      canonExpectedLoc <- canonicalizeLocation expectedLocation
+      canonActualLoc @?= canonExpectedLoc
+  check ExpectNoDefinitions = do
+    liftIO $ assertBool "Expecting no definitions" $ null defs
+  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
+  check _ = pure () -- all other expectations not relevant to getDefinition
+
+  assertOneDefinitionFound :: [Location] -> Session Location
+  assertOneDefinitionFound [def] = pure def
+  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)
+
+  assertRangeCorrect Location{_range = foundRange} expectedRange =
+    liftIO $ expectedRange @=? foundRange
+
+
+canonicalizeLocation :: Location -> IO Location
+canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
+
+defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]
+defToLocation (InL (Definition (InL l))) = [l]
+defToLocation (InL (Definition (InR ls))) = ls
+defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink
+defToLocation (InR (InR Null)) = []
diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs
@@ -25,6 +25,7 @@ import           Language.LSP.Test
 import           System.FilePath
 import           System.IO.Extra                 hiding (withTempDir)
 -- import Test.QuickCheck.Instances ()
+import           Config                          (checkDefs, mkL)
 import           Control.Lens                    ((^.))
 import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))
 import           GHC.TypeLits                    (symbolVal)
diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs
@@ -1,56 +1,49 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE ViewPatterns       #-}
 
 module FindDefinitionAndHoverTests (tests) where
 
 import           Control.Monad
-import           Control.Monad.IO.Class         (liftIO)
 import           Data.Foldable
 import           Data.Maybe
-import qualified Data.Text                      as T
-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)
-import           Development.IDE.GHC.Util
-import           Development.IDE.Test           (expectDiagnostics,
-                                                 standardizeQuotes)
-import           Development.IDE.Types.Location
-import qualified Language.LSP.Protocol.Lens     as L
-import           Language.LSP.Protocol.Types    hiding
-                                                (SemanticTokenAbsolute (..),
-                                                 SemanticTokenRelative (..),
-                                                 SemanticTokensEdit (..),
-                                                 mkRange)
+import qualified Data.Text                  as T
+import qualified Language.LSP.Protocol.Lens as L
 import           Language.LSP.Test
-import           System.FilePath
-import           System.Info.Extra              (isWindows)
+import           System.Info.Extra          (isWindows)
 
-import           Control.Lens                   ((^.))
+import           Control.Lens               ((^.))
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
-import           Text.Regex.TDFA                ((=~))
+-- import           TestUtils
+import           Config
+import           Debug.Trace                (traceM)
+import           Development.IDE            (readFileUtf8)
+import           Development.IDE.Test       (expectDiagnostics,
+                                             standardizeQuotes)
+import           System.Directory           (copyFile)
+import           System.FilePath            ((</>))
+import           Test.Hls
+import           Test.Hls.FileSystem        (copy, copyDir, file, toAbsFp)
+import           Text.Regex.TDFA            ((=~))
 
 tests :: TestTree
 tests = let
-
   tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
-  tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
-
-    -- Dirty the cache to check that definitions work even in the presence of iface files
-    liftIO $ runInDir dir $ do
-      let fooPath = dir </> "Foo.hs"
-      fooSource <- liftIO $ readFileUtf8 fooPath
-      fooDoc <- createDoc fooPath "haskell" fooSource
-      _ <- getHover fooDoc $ Position 4 3
-      closeDoc fooDoc
+  tst (get, check) pos sfp targetRange title =
+    testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
+        doc <- openDoc sfp "haskell"
+        waitForProgressDone
+        _x <- waitForTypecheck doc
+        found <- get doc pos
+        check found targetRange
 
-    doc <- openTestDataDoc (dir </> sfp)
-    waitForProgressDone
-    found <- get doc pos
-    check found targetRange
 
 
-
-  checkHover :: Maybe Hover -> Session [Expect] -> Session ()
+  checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
   checkHover hover expectations = traverse_ check =<< expectations where
 
+    check :: (HasCallStack) => Expect -> Session ()
     check expected =
       case hover of
         Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
@@ -100,11 +93,11 @@ tests = let
   mkFindTests tests = testGroup "get"
     [ testGroup "definition" $ mapMaybe fst tests
     , testGroup "hover"      $ mapMaybe snd tests
-    , checkFileCompiles sourceFilePath $
+    , testGroup "hover compile" [checkFileCompiles sourceFilePath $
         expectDiagnostics
           [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])
           , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])
-          ]
+          ]]
     , testGroup "type-definition" typeDefinitionTests
     , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]
 
@@ -117,8 +110,15 @@ tests = let
     , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
     ]
 
+  test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
   test runDef runHover look expect = testM runDef runHover look (return expect)
 
+  testM :: (HasCallStack) => (TestTree -> a)
+    -> (TestTree -> b)
+    -> Position
+    -> Session [Expect]
+    -> String
+    -> (a, b)
   testM runDef runHover look expect title =
     ( runDef   $ tst def   look sourceFilePath expect title
     , runHover $ tst hover look sourceFilePath expect title ) where
@@ -228,8 +228,11 @@ tests = let
         no = const Nothing -- don't run this test at all
         --skip = const Nothing -- unreliable, don't run
 
+xfail :: TestTree -> String -> TestTree
+xfail = flip expectFailBecause
+
 checkFileCompiles :: FilePath -> Session () -> TestTree
 checkFileCompiles fp diag =
-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
-    void (openTestDataDoc (dir </> fp))
+   testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do
+    _ <- openDoc fp "haskell"
     diag
diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs
@@ -1,9 +1,9 @@
 
 module HighlightTests (tests) where
 
+import           Config
 import           Control.Monad.IO.Class         (liftIO)
 import qualified Data.Text                      as T
-import           Development.IDE.GHC.Compat     (GhcVersion (..))
 import           Development.IDE.Types.Location
 import           Language.LSP.Protocol.Types    hiding
                                                 (SemanticTokenAbsolute (..),
@@ -13,11 +13,10 @@ import           Language.LSP.Protocol.Types    hiding
 import           Language.LSP.Test
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
 
 tests :: TestTree
 tests = testGroup "highlight"
-  [ testSessionWait "value" $ do
+  [ testWithDummyPluginEmpty "value" $ do
     doc <- createDoc "A.hs" "haskell" source
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 3 2)
@@ -27,15 +26,15 @@ tests = testGroup "highlight"
             , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)
             , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)
             ]
-  , testSessionWait "type" $ do
+  , testWithDummyPluginEmpty "type" $ do
     doc <- createDoc "A.hs" "haskell" source
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 2 8)
     liftIO $ highlights @?=
             [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)
             , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)
             ]
-  , testSessionWait "local" $ do
+  , testWithDummyPluginEmpty "local" $ do
     doc <- createDoc "A.hs" "haskell" source
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 6 5)
@@ -44,8 +43,8 @@ tests = testGroup "highlight"
             , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read)
             , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)
             ]
-  , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $
-        testSessionWait "record" $ do
+  ,
+        testWithDummyPluginEmpty "record" $ do
         doc <- createDoc "A.hs" "haskell" recsource
         _ <- waitForDiagnostics
         highlights <- getHighlights doc (Position 4 15)
diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs
@@ -206,26 +206,6 @@ knownIssueFor solution = go . \case
             Ignore -> ignoreTestBecause
         go False = const id
 
-data Expect
-  = ExpectRange Range -- Both gotoDef and hover should report this range
-  | ExpectLocation Location
---  | ExpectDefRange Range -- Only gotoDef should report this range
-  | ExpectHoverRange Range -- Only hover should report this range
-  | ExpectHoverText [T.Text] -- the hover message must contain these snippets
-  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets
-  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern
-  | ExpectExternFail -- definition lookup in other file expected to fail
-  | ExpectNoDefinitions
-  | ExpectNoHover
---  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
-  deriving Eq
-
-mkR :: UInt -> UInt -> UInt -> UInt -> Expect
-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
-
-mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect
-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
-
 
 
 testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
@@ -261,46 +241,6 @@ withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIME
 lspTestCapsNoFileWatches :: ClientCapabilities
 lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing
 
-openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
-openTestDataDoc path = do
-  source <- liftIO $ readFileUtf8 $ "ghcide/test/data" </> path
-  createDoc path "haskell" source
-
-pattern R :: UInt -> UInt -> UInt -> UInt -> Range
-pattern R x y x' y' = Range (Position x y) (Position x' y')
-
-checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()
-checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where
-  check (ExpectRange expectedRange) = do
-    def <- assertOneDefinitionFound defs
-    assertRangeCorrect def expectedRange
-  check (ExpectLocation expectedLocation) = do
-    def <- assertOneDefinitionFound defs
-    liftIO $ do
-      canonActualLoc <- canonicalizeLocation def
-      canonExpectedLoc <- canonicalizeLocation expectedLocation
-      canonActualLoc @?= canonExpectedLoc
-  check ExpectNoDefinitions = do
-    liftIO $ assertBool "Expecting no definitions" $ null defs
-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
-  check _ = pure () -- all other expectations not relevant to getDefinition
-
-  assertOneDefinitionFound :: [Location] -> Session Location
-  assertOneDefinitionFound [def] = pure def
-  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)
-
-  assertRangeCorrect Location{_range = foundRange} expectedRange =
-    liftIO $ expectedRange @=? foundRange
-
-canonicalizeLocation :: Location -> IO Location
-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
-
-defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]
-defToLocation (InL (Definition (InL l))) = [l]
-defToLocation (InL (Definition (InR ls))) = ls
-defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink
-defToLocation (InR (InR Null)) = []
-
 testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()
 testIde recorder arguments session = do
     config <- getConfigFromEnv
