diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index addfa53ff8..51487ce534 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,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 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/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 31f4dc05e0..f8232de343 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" @@ -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 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..68ca0d3350 100644 --- 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 index 7fb5ca79a2..3450404679 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,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 index d0c5644f41..0a13dd9717 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,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