Skip to content

Commit 45fe83f

Browse files
fendorfendor
committed
Add Tests for 'Goto Implementation' feature
1 parent bee70f9 commit 45fe83f

File tree

7 files changed

+309
-2
lines changed

7 files changed

+309
-2
lines changed

‎.hlint.yaml

+2
Original file line numberDiff line numberDiff line change
@@ -110,6 +110,7 @@
110110
- CompletionTests #Previously part of GHCIDE Main tests
111111
- DiagnosticTests #Previously part of GHCIDE Main tests
112112
- FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
113+
- FindImplementationAndHoverTests #Previously part of GHCIDE Main tests
113114
- TestUtils #Previously part of GHCIDE Main tests
114115
- CodeLensTests #Previously part of GHCIDE Main tests
115116

@@ -134,6 +135,7 @@
134135
- Ide.Plugin.Eval.Parse.Comments
135136
- Ide.Plugin.Eval.CodeLens
136137
- FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
138+
- FindImplementationAndHoverTests #Previously part of GHCIDE Main tests
137139

138140
- name: [Prelude.init, Data.List.init]
139141
within:

‎ghcide/test/data/hover/GotoImplementation.hs

+30
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
{-# LANGUAGE GADTs, GeneralisedNewtypeDeriving, DerivingStrategies #-}
2+
{-# OPTIONS_GHC -Wno-missing-methods #-}
3+
module GotoImplementation where
4+
5+
data AAA = AAA
6+
instance Num AAA where
7+
aaa :: Num x => x
8+
aaa = 1
9+
aaa1 :: AAA = aaa
10+
11+
class BBB a where
12+
bbb :: a -> a
13+
instance BBB AAA where
14+
bbb = const AAA
15+
bbbb :: AAA
16+
bbbb = bbb AAA
17+
18+
ccc :: Show a => a -> String
19+
ccc d = show d
20+
21+
newtype Q k = Q k
22+
deriving newtype (Eq, Show)
23+
ddd :: (Show k, Eq k) => k -> String
24+
ddd k = if Q k == Q k then show k else ""
25+
ddd1 = ddd (Q 0)
26+
27+
data GadtTest a where
28+
GadtTest :: Int -> GadtTest Int
29+
printUsingEvidence :: Show a => GadtTest a -> String
30+
printUsingEvidence (GadtTest i) = show i

‎ghcide/test/data/hover/hie.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}}
1+
cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}}

‎ghcide/test/exe/Config.hs

+3
Original file line numberDiff line numberDiff line change
@@ -110,6 +110,7 @@ data Expect
110110
| ExpectHoverTextRegex T.Text -- the hover message must match this pattern
111111
| ExpectExternFail -- definition lookup in other file expected to fail
112112
| ExpectNoDefinitions
113+
| ExpectNoImplementations
113114
| ExpectNoHover
114115
-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
115116
deriving Eq
@@ -134,6 +135,8 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta
134135
canonActualLoc <- canonicalizeLocation def
135136
canonExpectedLoc <- canonicalizeLocation expectedLocation
136137
canonActualLoc @?= canonExpectedLoc
138+
check ExpectNoImplementations = do
139+
liftIO $ assertBool "Expecting no implementations" $ null defs
137140
check ExpectNoDefinitions = do
138141
liftIO $ assertBool "Expecting no definitions" $ null defs
139142
check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

‎ghcide/test/exe/FindImplementationAndHoverTests.hs

+269
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,269 @@
1+
{-# LANGUAGE ExplicitNamespaces #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE ViewPatterns #-}
4+
5+
module FindImplementationAndHoverTests (tests) where
6+
7+
import Control.Monad
8+
import Data.Foldable
9+
import Data.Maybe
10+
import qualified Data.Text as T
11+
import qualified Language.LSP.Protocol.Lens as L
12+
import Language.LSP.Test
13+
import Text.Regex.TDFA ((=~))
14+
15+
import Config
16+
import Control.Category ((>>>))
17+
import Control.Lens ((^.))
18+
import Data.Text (Text)
19+
import Development.IDE.Test (standardizeQuotes)
20+
import Test.Hls
21+
import Test.Hls.FileSystem (copyDir)
22+
23+
tests :: TestTree
24+
tests = let
25+
tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
26+
tst (get, check) pos sfp targetRange title =
27+
testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
28+
doc <- openDoc sfp "haskell"
29+
waitForProgressDone
30+
_x <- waitForTypecheck doc
31+
found <- get doc pos
32+
check found targetRange
33+
34+
checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
35+
checkHover hover expectations = traverse_ check =<< expectations where
36+
37+
check :: (HasCallStack) => Expect -> Session ()
38+
check expected =
39+
case hover of
40+
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
41+
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
42+
,_range = rangeInHover } ->
43+
case expected of
44+
ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
45+
ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
46+
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
47+
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
48+
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
49+
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
50+
_ -> pure () -- all other expectations not relevant to hover
51+
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
52+
53+
extractLineColFromHoverMsg :: T.Text -> [T.Text]
54+
extractLineColFromHoverMsg =
55+
-- Hover messages contain multiple lines, and we are looking for the definition
56+
-- site
57+
T.lines
58+
-- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*"
59+
-- So filter by the start of the line
60+
>>> mapMaybe (T.stripPrefix "*Defined at")
61+
-- There can be multiple definitions per hover message!
62+
-- See the test "field in record definition" for example.
63+
-- The tests check against the last line that contains the above line.
64+
>>> last
65+
-- [" /tmp/", "22:3*"]
66+
>>> T.splitOn (sourceFileName <> ":")
67+
-- "22:3*"
68+
>>> last
69+
-- ["22:3", ""]
70+
>>> T.splitOn "*"
71+
-- "22:3"
72+
>>> head
73+
-- ["22", "3"]
74+
>>> T.splitOn ":"
75+
76+
checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
77+
checkHoverRange expectedRange rangeInHover msg =
78+
let
79+
lineCol = extractLineColFromHoverMsg msg
80+
-- looks like hovers use 1-based numbering while definitions use 0-based
81+
-- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
82+
adjust Position{_line = l, _character = c} =
83+
Position{_line = l + 1, _character = c + 1}
84+
in
85+
case map (read . T.unpack) lineCol of
86+
[l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c
87+
_ -> liftIO $ assertFailure $
88+
"expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
89+
"\n but got: " <> show (msg, rangeInHover)
90+
91+
assertFoundIn :: T.Text -> T.Text -> Assertion
92+
assertFoundIn part whole = assertBool
93+
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
94+
(part `T.isInfixOf` whole)
95+
96+
assertNotFoundIn :: T.Text -> T.Text -> Assertion
97+
assertNotFoundIn part whole = assertBool
98+
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
99+
(not . T.isInfixOf part $ whole)
100+
101+
sourceFilePath = T.unpack sourceFileName
102+
sourceFileName = "GotoImplementation.hs"
103+
104+
mkFindTests tests = testGroup "goto implementation"
105+
[ testGroup "implementation" $ mapMaybe fst allTests
106+
, testGroup "hover" $ mapMaybe snd allTests
107+
]
108+
where
109+
allTests = tests ++ recordDotSyntaxTests
110+
111+
recordDotSyntaxTests =
112+
-- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax
113+
[ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent"
114+
, test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child"
115+
, test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child"
116+
, test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild"
117+
]
118+
119+
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
120+
test runImpl runHover look expect = testM runImpl runHover look (return expect)
121+
122+
testM :: (HasCallStack) => (TestTree -> a)
123+
-> (TestTree -> b)
124+
-> Position
125+
-> Session [Expect]
126+
-> String
127+
-> (a, b)
128+
testM = testM' sourceFilePath
129+
130+
test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
131+
test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect)
132+
133+
testM' :: (HasCallStack)
134+
=> FilePath
135+
-> (TestTree -> a)
136+
-> (TestTree -> b)
137+
-> Position
138+
-> Session [Expect]
139+
-> String
140+
-> (a, b)
141+
testM' sourceFile runImpl runHover look expect title =
142+
( runImpl $ tst impl look sourceFile expect title
143+
, runHover $ tst hover look sourceFile expect title ) where
144+
impl = (getImplementations, checkDefs)
145+
hover = (getHover , checkHover)
146+
147+
aaaL = Position 8 15; aaaR = mkRange 5 9 5 16;
148+
aaa =
149+
[ ExpectRanges [aaaR]
150+
, ExpectHoverText (evidenceBoundByConstraint "Num" "AAA")
151+
]
152+
153+
bbbL = Position 15 8; bbbR = mkRange 12 9 12 16;
154+
bbb =
155+
[ ExpectRanges [bbbR]
156+
, ExpectHoverText (evidenceBoundByConstraint "BBB" "AAA")
157+
]
158+
cccL = Position 18 11;
159+
ccc =
160+
[ ExpectNoImplementations
161+
, ExpectHoverText (evidenceBySignatureOrPattern "Show" "a")
162+
]
163+
dddShowR = mkRange 21 26 21 30; dddEqR = mkRange 21 22 21 24
164+
dddL1 = Position 23 16;
165+
ddd1 =
166+
[ ExpectRanges [dddEqR]
167+
, ExpectHoverText
168+
[ constraintEvidence "Eq" "(Q k)"
169+
, evidenceGoal' "'forall k. Eq k => Eq (Q k)'"
170+
, boundByInstanceOf "Eq"
171+
, evidenceGoal "Eq" "k"
172+
, boundByTypeSigOrPattern
173+
]
174+
]
175+
dddL2 = Position 23 29;
176+
ddd2 =
177+
[ ExpectNoImplementations
178+
, ExpectHoverText (evidenceBySignatureOrPattern "Show" "k")
179+
]
180+
dddL3 = Position 24 8;
181+
ddd3 =
182+
[ ExpectRanges [dddEqR, dddShowR]
183+
, ExpectHoverText
184+
[ constraintEvidence "Show" "(Q Integer)"
185+
, evidenceGoal' "'forall k. Show k => Show (Q k)'"
186+
, boundByInstance
187+
, evidenceGoal "Show" "Integer"
188+
, usingExternalInstance
189+
, constraintEvidence "Eq" "(Q Integer)"
190+
, evidenceGoal' "'forall k. Eq k => Eq (Q k)'"
191+
, boundByInstance
192+
, evidenceGoal "Eq" "Integer"
193+
, usingExternalInstance
194+
]
195+
]
196+
gadtL = Position 29 35;
197+
gadt =
198+
[ ExpectNoImplementations
199+
, ExpectHoverText
200+
[ constraintEvidence "Show" "Int"
201+
, evidenceGoal "Show" "a"
202+
, boundByTypeSigOrPattern
203+
, evidenceGoal' "'a ~ Int'"
204+
, boundByPattern
205+
]
206+
]
207+
in
208+
mkFindTests
209+
-- impl hover look expect
210+
[
211+
test yes yes aaaL aaa "locally defined class instance"
212+
, test yes yes bbbL bbb "locally defined class and instance"
213+
, test yes yes cccL ccc "bound by type signature"
214+
, test yes yes dddL1 ddd1 "newtype Eq evidence"
215+
, test yes yes dddL2 ddd2 "Show evidence"
216+
, test yes yes dddL3 ddd3 "evidence construction"
217+
, test yes yes gadtL gadt "GADT evidence"
218+
]
219+
where yes :: (TestTree -> Maybe TestTree)
220+
yes = Just -- test should run and pass
221+
no = const Nothing -- don't run this test at all
222+
223+
-- ----------------------------------------------------------------------------
224+
-- Helper functions for creating hover message verification
225+
-- ----------------------------------------------------------------------------
226+
227+
evidenceBySignatureOrPattern :: Text -> Text -> [Text]
228+
evidenceBySignatureOrPattern tyclass varname =
229+
[ constraintEvidence tyclass varname
230+
, boundByTypeSigOrPattern
231+
]
232+
233+
evidenceBoundByConstraint :: Text -> Text -> [Text]
234+
evidenceBoundByConstraint tyclass varname =
235+
[ constraintEvidence tyclass varname
236+
, boundByInstanceOf tyclass
237+
]
238+
239+
boundByTypeSigOrPattern :: Text
240+
boundByTypeSigOrPattern = "bound by type signature or pattern"
241+
242+
boundByInstance :: Text
243+
boundByInstance =
244+
"bound by an instance of"
245+
246+
boundByInstanceOf :: Text -> Text
247+
boundByInstanceOf tyvar =
248+
"bound by an instance of class " <> tyvar
249+
250+
boundByPattern :: Text
251+
boundByPattern =
252+
"bound by a pattern"
253+
254+
usingExternalInstance :: Text
255+
usingExternalInstance =
256+
"using an external instance"
257+
258+
constraintEvidence :: Text -> Text -> Text
259+
constraintEvidence tyclass varname = "Evidence of constraint " <> quotedName tyclass varname
260+
261+
-- | A goal in the evidence tree.
262+
evidenceGoal :: Text -> Text -> Text
263+
evidenceGoal tyclass varname = "- " <> quotedName tyclass varname
264+
265+
evidenceGoal' :: Text -> Text
266+
evidenceGoal' t = "- " <> t
267+
268+
quotedName :: Text -> Text -> Text
269+
quotedName tyclass varname = "'" <> tyclass <> " " <> varname <> "'"

‎ghcide/test/exe/Main.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -45,12 +45,13 @@ import DependentFileTest
4545
import DiagnosticTests
4646
import ExceptionTests
4747
import FindDefinitionAndHoverTests
48+
import FindImplementationAndHoverTests
4849
import GarbageCollectionTests
4950
import HaddockTests
5051
import HighlightTests
5152
import IfaceTests
5253
import InitializeResponseTests
53-
import LogType ()
54+
import LogType ()
5455
import NonLspCommandLine
5556
import OpenCloseTest
5657
import OutlineTests
@@ -78,6 +79,7 @@ main = do
7879
, OutlineTests.tests
7980
, HighlightTests.tests
8081
, FindDefinitionAndHoverTests.tests
82+
, FindImplementationAndHoverTests.tests
8183
, PluginSimpleTests.tests
8284
, PreprocessorTests.tests
8385
, THTests.tests

‎haskell-language-server.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -2186,6 +2186,7 @@ test-suite ghcide-tests
21862186
DiagnosticTests
21872187
ExceptionTests
21882188
FindDefinitionAndHoverTests
2189+
FindImplementationAndHoverTests
21892190
FuzzySearch
21902191
GarbageCollectionTests
21912192
HaddockTests

0 commit comments

Comments
 (0)