diff --git a/.hlint.yaml b/.hlint.yaml index 0bf0e0a313..edc6886871 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -110,6 +110,7 @@ - CompletionTests #Previously part of GHCIDE Main tests - DiagnosticTests #Previously part of GHCIDE Main tests - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests + - FindImplementationAndHoverTests #Previously part of GHCIDE Main tests - TestUtils #Previously part of GHCIDE Main tests - CodeLensTests #Previously part of GHCIDE Main tests @@ -134,6 +135,7 @@ - Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.CodeLens - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests + - FindImplementationAndHoverTests #Previously part of GHCIDE Main tests - name: [Prelude.init, Data.List.init] within: diff --git a/ghcide/test/data/hover/GotoImplementation.hs b/ghcide/test/data/hover/GotoImplementation.hs new file mode 100644 index 0000000000..8d7dc20b0d --- /dev/null +++ b/ghcide/test/data/hover/GotoImplementation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs, GeneralisedNewtypeDeriving, DerivingStrategies #-} + +module GotoImplementation where + +data AAA = AAA +instance Num AAA where +aaa :: Num x => x +aaa = 1 +aaa1 :: AAA = aaa + +class BBB a where + bbb :: a -> a +instance BBB AAA where + bbb = const AAA +bbbb :: AAA +bbbb = bbb AAA + +ccc :: Show a => a -> String +ccc d = show d + +newtype Q k = Q k + deriving newtype (Eq, Show) +ddd :: (Show k, Eq k) => k -> String +ddd k = if Q k == Q k then show k else "" +ddd1 = ddd (Q 0) + +data GadtTest a where + GadtTest :: Int -> GadtTest Int +printUsingEvidence :: Show a => GadtTest a -> String +printUsingEvidence (GadtTest i) = show i diff --git a/ghcide/test/data/hover/hie.yaml b/ghcide/test/data/hover/hie.yaml index e2b3e97c5d..de7cc991cc 100644 --- a/ghcide/test/data/hover/hie.yaml +++ b/ghcide/test/data/hover/hie.yaml @@ -1 +1 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}} diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 56e9af103a..75e33d3579 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -110,6 +110,7 @@ data Expect | ExpectHoverTextRegex T.Text -- the hover message must match this pattern | ExpectExternFail -- definition lookup in other file expected to fail | ExpectNoDefinitions + | ExpectNoImplementations | ExpectNoHover -- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples deriving Eq @@ -134,6 +135,8 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta canonActualLoc <- canonicalizeLocation def canonExpectedLoc <- canonicalizeLocation expectedLocation canonActualLoc @?= canonExpectedLoc + check ExpectNoImplementations = do + liftIO $ assertBool "Expecting no implementations" $ null defs check ExpectNoDefinitions = do liftIO $ assertBool "Expecting no definitions" $ null defs check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" diff --git a/ghcide/test/exe/FindImplementationAndHoverTests.hs b/ghcide/test/exe/FindImplementationAndHoverTests.hs new file mode 100644 index 0000000000..0bbc400e34 --- /dev/null +++ b/ghcide/test/exe/FindImplementationAndHoverTests.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindImplementationAndHoverTests (tests) where + +import Control.Monad +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test +import Text.Regex.TDFA ((=~)) + +import Config +import Control.Category ((>>>)) +import Control.Lens ((^.)) +import Data.Text (Text) +import Development.IDE.Test (standardizeQuotes) +import Test.Hls +import Test.Hls.FileSystem (copyDir) + +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 = + testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + _x <- waitForTypecheck doc + found <- get doc pos + check found targetRange + + 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" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = + -- Hover messages contain multiple lines, and we are looking for the definition + -- site + T.lines + -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" + -- So filter by the start of the line + >>> mapMaybe (T.stripPrefix "*Defined at") + -- There can be multiple definitions per hover message! + -- See the test "field in record definition" for example. + -- The tests check against the last line that contains the above line. + >>> last + -- [" /tmp/", "22:3*"] + >>> T.splitOn (sourceFileName <> ":") + -- "22:3*" + >>> last + -- ["22:3", ""] + >>> T.splitOn "*" + -- "22:3" + >>> head + -- ["22", "3"] + >>> T.splitOn ":" + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoImplementation.hs" + + mkFindTests tests = testGroup "goto implementation" + [ testGroup "implementation" $ mapMaybe fst allTests + , testGroup "hover" $ mapMaybe snd allTests + ] + where + allTests = tests ++ recordDotSyntaxTests + + recordDotSyntaxTests = + -- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax + [ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent" + , test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild" + ] + + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test runImpl runHover look expect = testM runImpl runHover look (return expect) + + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM = testM' sourceFilePath + + test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect) + + testM' :: (HasCallStack) + => FilePath + -> (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM' sourceFile runImpl runHover look expect title = + ( runImpl $ tst impl look sourceFile expect title + , runHover $ tst hover look sourceFile expect title ) where + impl = (getImplementations, checkDefs) + hover = (getHover , checkHover) + + aaaL = Position 8 15; aaaR = mkRange 5 9 5 16; + aaa = + [ ExpectRanges [aaaR] + , ExpectHoverText (evidenceBoundByConstraint "Num" "AAA") + ] + + bbbL = Position 15 8; bbbR = mkRange 12 9 12 16; + bbb = + [ ExpectRanges [bbbR] + , ExpectHoverText (evidenceBoundByConstraint "BBB" "AAA") + ] + cccL = Position 18 11; + ccc = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "a") + ] + dddShowR = mkRange 21 26 21 30; dddEqR = mkRange 21 22 21 24 + dddL1 = Position 23 16; + ddd1 = + [ ExpectRanges [dddEqR] + , ExpectHoverText + [ constraintEvidence "Eq" "(Q k)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstanceOf "Eq" + , evidenceGoal "Eq" "k" + , boundByTypeSigOrPattern + ] + ] + dddL2 = Position 23 29; + ddd2 = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "k") + ] + dddL3 = Position 24 8; + ddd3 = + [ ExpectRanges [dddEqR, dddShowR] + , ExpectHoverText + [ constraintEvidence "Show" "(Q Integer)" + , evidenceGoal' "'forall k. Show k => Show (Q k)'" + , boundByInstance + , evidenceGoal "Show" "Integer" + , usingExternalInstance + , constraintEvidence "Eq" "(Q Integer)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstance + , evidenceGoal "Eq" "Integer" + , usingExternalInstance + ] + ] + gadtL = Position 29 35; + gadt = + [ ExpectNoImplementations + , ExpectHoverText + [ constraintEvidence "Show" "Int" + , evidenceGoal "Show" "a" + , boundByTypeSigOrPattern + , evidenceGoal' "'a ~ Int'" + , boundByPattern + ] + ] + in + mkFindTests + -- impl hover look expect + [ + test yes yes aaaL aaa "locally defined class instance" + , test yes yes bbbL bbb "locally defined class and instance" + , test yes yes cccL ccc "bound by type signature" + , test yes yes dddL1 ddd1 "newtype Eq evidence" + , test yes yes dddL2 ddd2 "Show evidence" + , test yes yes dddL3 ddd3 "evidence construction" + , test yes yes gadtL gadt "GADT evidence" + ] + where yes :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + no = const Nothing -- don't run this test at all + +-- ---------------------------------------------------------------------------- +-- Helper functions for creating hover message verification +-- ---------------------------------------------------------------------------- + +evidenceBySignatureOrPattern :: Text -> Text -> [Text] +evidenceBySignatureOrPattern tyclass varname = + [ constraintEvidence tyclass varname + , boundByTypeSigOrPattern + ] + +evidenceBoundByConstraint :: Text -> Text -> [Text] +evidenceBoundByConstraint tyclass varname = + [ constraintEvidence tyclass varname + , boundByInstanceOf tyclass + ] + +boundByTypeSigOrPattern :: Text +boundByTypeSigOrPattern = "bound by type signature or pattern" + +boundByInstance :: Text +boundByInstance = + "bound by an instance of" + +boundByInstanceOf :: Text -> Text +boundByInstanceOf tyvar = + "bound by an instance of class " <> tyvar + +boundByPattern :: Text +boundByPattern = + "bound by a pattern" + +usingExternalInstance :: Text +usingExternalInstance = + "using an external instance" + +constraintEvidence :: Text -> Text -> Text +constraintEvidence tyclass varname = "Evidence of constraint " <> quotedName tyclass varname + +-- | A goal in the evidence tree. +evidenceGoal :: Text -> Text -> Text +evidenceGoal tyclass varname = "- " <> quotedName tyclass varname + +evidenceGoal' :: Text -> Text +evidenceGoal' t = "- " <> t + +quotedName :: Text -> Text -> Text +quotedName tyclass varname = "'" <> tyclass <> " " <> varname <> "'" diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6c8091840d..6bca4245be 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -45,12 +45,13 @@ import DependentFileTest import DiagnosticTests import ExceptionTests import FindDefinitionAndHoverTests +import FindImplementationAndHoverTests import GarbageCollectionTests import HaddockTests import HighlightTests import IfaceTests import InitializeResponseTests -import LogType () +import LogType () import NonLspCommandLine import OpenCloseTest import OutlineTests @@ -78,6 +79,7 @@ main = do , OutlineTests.tests , HighlightTests.tests , FindDefinitionAndHoverTests.tests + , FindImplementationAndHoverTests.tests , PluginSimpleTests.tests , PreprocessorTests.tests , THTests.tests diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 447882a61e..3cdcca43e7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2186,6 +2186,7 @@ test-suite ghcide-tests DiagnosticTests ExceptionTests FindDefinitionAndHoverTests + FindImplementationAndHoverTests FuzzySearch GarbageCollectionTests HaddockTests