Add Tests for 'Goto Implementation' feature

.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:

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

ghcide/test/data/hover/hie.yaml

@@ -1 +1 @@
-cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}}
+cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}}

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"

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 <> ":<LINE>:<COL>**[...]", 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 <> "'"

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

haskell-language-server.cabal

@@ -2186,6 +2186,7 @@ test-suite ghcide-tests
     DiagnosticTests
     ExceptionTests
     FindDefinitionAndHoverTests
+    FindImplementationAndHoverTests
     FuzzySearch
     GarbageCollectionTests
     HaddockTests