From 30f578ccbd79c818fd673dd48e6387a3e8b2d728 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 00:45:31 +0800 Subject: [PATCH 1/6] migrate FindDefinitionAndHoverTests --- ghcide/test/exe/BootTests.hs | 1 + ghcide/test/exe/Config.hs | 68 +++++++++++++++- ghcide/test/exe/CradleTests.hs | 1 + .../test/exe/FindDefinitionAndHoverTests.hs | 78 ++++++++++--------- ghcide/test/exe/TestUtils.hs | 56 ------------- 5 files changed, 108 insertions(+), 96 deletions(-) diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 3e4d87c550..07615f41d3 100644 --- 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 index 4ec7901bf3..f18b20d958 100644 --- 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" @@ -42,3 +46,59 @@ testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs 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 index db71fb38f0..196bea95e6 100644 --- 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 index 04ede6579b..1450cf2696 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -1,56 +1,47 @@ +{-# 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 Development.IDE (readFileUtf8) +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +import System.FilePath (()) +import Test.Hls +import Test.Hls.FileSystem (copyDir, 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 - - doc <- openTestDataDoc (dir sfp) - waitForProgressDone - found <- get doc pos - check found targetRange + 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 - 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" @@ -117,8 +108,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 +226,16 @@ 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)) + testWithDummyPluginEmpty' ("hover: Does " ++ fp ++ " compile") $ \fs -> do + void (openTestDataDoc $ toAbsFp fs fp) diag + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "ghcide/test/data" path + createDoc path "haskell" source diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index d0c5644f41..956870f5dd 100644 --- 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,10 @@ 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 From ae65b0197b601bbfcd80601eead1c70809303904 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 01:06:53 +0800 Subject: [PATCH 2/6] migrate highlighttests --- ghcide/test/exe/Config.hs | 2 -- ghcide/test/exe/HighlightTests.hs | 21 +++++++++++++-------- ghcide/test/exe/TestUtils.hs | 4 ---- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index f18b20d958..32747ecb1b 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -47,8 +47,6 @@ testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs 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 diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs index 7fb5ca79a2..02a6f5de35 100644 --- 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,7 +26,7 @@ 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) @@ -35,7 +34,7 @@ tests = testGroup "highlight" [ 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,9 @@ 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 + , +-- knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ + testWithDummyPluginEmpty "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) @@ -55,7 +55,12 @@ tests = testGroup "highlight" ] highlights <- getHighlights doc (Position 3 17) liftIO $ highlights @?= - [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + [ + DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 32 3 38) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 4 4 4 7) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) ] ] diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 956870f5dd..0a13dd9717 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -241,10 +241,6 @@ withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIME lspTestCapsNoFileWatches :: ClientCapabilities lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () testIde recorder arguments session = do config <- getConfigFromEnv From eff97b147b8df2f20ac7064225a2288768f1069e Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 02:30:26 +0800 Subject: [PATCH 3/6] fix hover --- ghcide/test/exe/Config.hs | 6 ++++++ ghcide/test/exe/FindDefinitionAndHoverTests.hs | 17 +++++++---------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 32747ecb1b..d7b181741d 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -28,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 diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 1450cf2696..68ca0d3350 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -17,12 +17,14 @@ import Test.Tasty import Test.Tasty.HUnit -- 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 (copyDir, toAbsFp) +import Test.Hls.FileSystem (copy, copyDir, file, toAbsFp) import Text.Regex.TDFA ((=~)) tests :: TestTree @@ -91,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 ] @@ -231,11 +233,6 @@ xfail = flip expectFailBecause checkFileCompiles :: FilePath -> Session () -> TestTree checkFileCompiles fp diag = - testWithDummyPluginEmpty' ("hover: Does " ++ fp ++ " compile") $ \fs -> do - void (openTestDataDoc $ toAbsFp fs fp) + testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do + _ <- openDoc fp "haskell" diag - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "ghcide/test/data" path - createDoc path "haskell" source From d9cbf92e86037c053f4ea167468b122cc67150a1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 19:46:20 +0800 Subject: [PATCH 4/6] fix highlight --- ghcide/src/Development/IDE/GHC/Compat.hs | 4 +++- ghcide/src/Development/IDE/Spans/AtPoint.hs | 3 ++- ghcide/test/exe/HighlightTests.hs | 7 +------ 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index addfa53ff8..35023991d0 100644 --- 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,8 @@ isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{} = True isQualifiedImport _ = False - +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 index 8e1508cdd2..5bff7d62f5 100644 --- 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/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs index 02a6f5de35..5a6cc1b2e6 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ b/ghcide/test/exe/HighlightTests.hs @@ -44,7 +44,6 @@ tests = testGroup "highlight" , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) ] , --- knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ testWithDummyPluginEmpty "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics @@ -56,11 +55,7 @@ tests = testGroup "highlight" highlights <- getHighlights doc (Position 3 17) liftIO $ highlights @?= [ - DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 3 32 3 38) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 4 4 4 7) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) ] ] From 1a25b789baafc09c6e42d3d6c4b5bb987b9f95c0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 19:50:10 +0800 Subject: [PATCH 5/6] format --- ghcide/test/exe/HighlightTests.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs index 5a6cc1b2e6..3450404679 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ b/ghcide/test/exe/HighlightTests.hs @@ -54,8 +54,7 @@ tests = testGroup "highlight" ] highlights <- getHighlights doc (Position 3 17) liftIO $ highlights @?= - [ - DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) ] ] From fed7b668b082eaf822543846cb17c0616eae6195 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 20:50:00 +0800 Subject: [PATCH 6/6] add doc --- ghcide/src/Development/IDE/GHC/Compat.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 35023991d0..51487ce534 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -472,6 +472,7 @@ 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