Skip to content

Commit 0557bba

Browse files
fendorfendor
committed
Add Tests for 'Goto Implementation' feature
1 parent c127905 commit 0557bba

File tree

6 files changed

+191
-1
lines changed

6 files changed

+191
-1
lines changed

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

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{-# LANGUAGE GADTs #-}
2+
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+
data DDD a where
19+
DDD1 :: Int -> DDD Int
20+
DDD2 :: String -> DDD String
21+
ddd :: DDD a -> a
22+
ddd d = case d of
23+
DDD1 a -> a + a
24+
DDD2 a -> a ++ a
25+

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

Lines changed: 1 addition & 1 deletion
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

Lines changed: 3 additions & 0 deletions
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

Lines changed: 159 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,159 @@
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 Development.IDE.Test (standardizeQuotes)
19+
import Test.Hls
20+
import Test.Hls.FileSystem (copyDir)
21+
22+
tests :: TestTree
23+
tests = let
24+
tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
25+
tst (get, check) pos sfp targetRange title =
26+
testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
27+
doc <- openDoc sfp "haskell"
28+
waitForProgressDone
29+
_x <- waitForTypecheck doc
30+
found <- get doc pos
31+
check found targetRange
32+
33+
checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
34+
checkHover hover expectations = traverse_ check =<< expectations where
35+
36+
check :: (HasCallStack) => Expect -> Session ()
37+
check expected =
38+
case hover of
39+
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
40+
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
41+
,_range = rangeInHover } ->
42+
case expected of
43+
ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
44+
ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
45+
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
46+
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
47+
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
48+
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
49+
_ -> pure () -- all other expectations not relevant to hover
50+
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
51+
52+
extractLineColFromHoverMsg :: T.Text -> [T.Text]
53+
extractLineColFromHoverMsg =
54+
-- Hover messages contain multiple lines, and we are looking for the definition
55+
-- site
56+
T.lines
57+
-- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*"
58+
-- So filter by the start of the line
59+
>>> mapMaybe (T.stripPrefix "*Defined at")
60+
-- There can be multiple definitions per hover message!
61+
-- See the test "field in record definition" for example.
62+
-- The tests check against the last line that contains the above line.
63+
>>> last
64+
-- [" /tmp/", "22:3*"]
65+
>>> T.splitOn (sourceFileName <> ":")
66+
-- "22:3*"
67+
>>> last
68+
-- ["22:3", ""]
69+
>>> T.splitOn "*"
70+
-- "22:3"
71+
>>> head
72+
-- ["22", "3"]
73+
>>> T.splitOn ":"
74+
75+
checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
76+
checkHoverRange expectedRange rangeInHover msg =
77+
let
78+
lineCol = extractLineColFromHoverMsg msg
79+
-- looks like hovers use 1-based numbering while definitions use 0-based
80+
-- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
81+
adjust Position{_line = l, _character = c} =
82+
Position{_line = l + 1, _character = c + 1}
83+
in
84+
case map (read . T.unpack) lineCol of
85+
[l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c
86+
_ -> liftIO $ assertFailure $
87+
"expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
88+
"\n but got: " <> show (msg, rangeInHover)
89+
90+
assertFoundIn :: T.Text -> T.Text -> Assertion
91+
assertFoundIn part whole = assertBool
92+
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
93+
(part `T.isInfixOf` whole)
94+
95+
assertNotFoundIn :: T.Text -> T.Text -> Assertion
96+
assertNotFoundIn part whole = assertBool
97+
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
98+
(not . T.isInfixOf part $ whole)
99+
100+
sourceFilePath = T.unpack sourceFileName
101+
sourceFileName = "GotoImplementation.hs"
102+
103+
mkFindTests tests = testGroup "goto implementation"
104+
[ testGroup "implementation" $ mapMaybe fst allTests
105+
, testGroup "hover" $ mapMaybe snd allTests
106+
]
107+
where
108+
allTests = tests ++ recordDotSyntaxTests
109+
110+
recordDotSyntaxTests =
111+
-- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax
112+
[ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent"
113+
, test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child"
114+
, test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child"
115+
, test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild"
116+
]
117+
118+
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
119+
test runImpl runHover look expect = testM runImpl runHover look (return expect)
120+
121+
testM :: (HasCallStack) => (TestTree -> a)
122+
-> (TestTree -> b)
123+
-> Position
124+
-> Session [Expect]
125+
-> String
126+
-> (a, b)
127+
testM = testM' sourceFilePath
128+
129+
test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
130+
test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect)
131+
132+
testM' :: (HasCallStack)
133+
=> FilePath
134+
-> (TestTree -> a)
135+
-> (TestTree -> b)
136+
-> Position
137+
-> Session [Expect]
138+
-> String
139+
-> (a, b)
140+
testM' sourceFile runImpl runHover look expect title =
141+
( runImpl $ tst impl look sourceFile expect title
142+
, runHover $ tst hover look sourceFile expect title ) where
143+
impl = (getImplementations, checkDefs)
144+
hover = (getHover , checkHover)
145+
146+
-- search locations expectations on results
147+
-- TODO: Lookup of record field should return exactly one result
148+
aaaL = Position 8 15; aaaR = mkRange 5 9 5 16; aaa = [ExpectRanges [aaaR], ExpectHoverText ["Evidence of constraint 'Num AAA'", "bound by an instance of class Num"]]
149+
bbbL = Position 15 8; bbbR = mkRange 12 9 12 16; bbb = [ExpectRanges [bbbR], ExpectHoverText ["Evidence of constraint 'BBB AAA'", "bound by an instance of class BBB"]]
150+
in
151+
mkFindTests
152+
-- impl hover look expect
153+
[
154+
test yes yes aaaL aaa "locally defined class instance"
155+
, test yes yes bbbL bbb "locally defined class and instance"
156+
]
157+
where yes :: (TestTree -> Maybe TestTree)
158+
yes = Just -- test should run and pass
159+
no = const Nothing -- don't run this test at all

‎ghcide/test/exe/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ import DependentFileTest
4545
import DiagnosticTests
4646
import ExceptionTests
4747
import FindDefinitionAndHoverTests
48+
import FindImplementationAndHoverTests
4849
import GarbageCollectionTests
4950
import HaddockTests
5051
import HighlightTests
@@ -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

Lines changed: 1 addition & 0 deletions
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)