Skip to content

Commit 2779dbb

Browse files
jacgcocreature
authored andcommitted
Add tests for find-definition and hover (#139)
* Add find definition tests * Add tests for hovers
1 parent 9d45eee commit 2779dbb

File tree

2 files changed

+129
-7
lines changed

2 files changed

+129
-7
lines changed

ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -188,6 +188,7 @@ test-suite ghcide-tests
188188
parser-combinators,
189189
tasty,
190190
tasty-hunit,
191+
tasty-expected-failure,
191192
text
192193
hs-source-dirs: test/cabal test/exe test/src
193194
include-dirs: include

test/exe/Main.hs

Lines changed: 128 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import System.IO.Extra
2020
import System.Directory
2121
import Test.Tasty
2222
import Test.Tasty.HUnit
23+
import Test.Tasty.ExpectedFailure
2324

2425

2526
main :: IO ()
@@ -31,9 +32,9 @@ main = defaultMain $ testGroup "HIE"
3132
void (message :: Session ProgressDoneNotification)
3233
, diagnosticTests
3334
, codeActionTests
35+
, findDefinitionTests
3436
]
3537

36-
3738
diagnosticTests :: TestTree
3839
diagnosticTests = testGroup "diagnostics"
3940
[ testSession "fix syntax error" $ do
@@ -113,10 +114,10 @@ diagnosticTests = testGroup "diagnostics"
113114
expectedDs aMessage =
114115
[ ("A.hs", [(DsError, (2,4), aMessage)])
115116
, ("B.hs", [(DsError, (3,4), bMessage)])]
116-
deferralTest title binding message = testSession title $ do
117+
deferralTest title binding msg = testSession title $ do
117118
_ <- openDoc' "A.hs" "haskell" $ sourceA binding
118119
_ <- openDoc' "B.hs" "haskell" sourceB
119-
expectDiagnostics $ expectedDs message
120+
expectDiagnostics $ expectedDs msg
120121
in
121122
[ deferralTest "type error" "True" "Couldn't match expected type"
122123
, deferralTest "typed hole" "_" "Found hole"
@@ -561,14 +562,14 @@ fillTypedHoleTests = let
561562

562563
addSigActionTests :: TestTree
563564
addSigActionTests = let
564-
head = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
565+
header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
565566
, "module Sigs where"]
566-
before def = T.unlines [head, def]
567-
after def sig = T.unlines [head, sig, def]
567+
before def = T.unlines [header, def]
568+
after' def sig = T.unlines [header, sig, def]
568569

569570
def >:: sig = testSession (T.unpack def) $ do
570571
let originalCode = before def
571-
let expectedCode = after def sig
572+
let expectedCode = after' def sig
572573
doc <- openDoc' "Sigs.hs" "haskell" originalCode
573574
_ <- waitForDiagnostics
574575
actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
@@ -586,6 +587,123 @@ addSigActionTests = let
586587
, "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
587588
]
588589

590+
findDefinitionTests :: TestTree
591+
findDefinitionTests = let
592+
593+
tst (get, check) pos targetRange title = testSession title $ do
594+
doc <- openDoc' "Testing.hs" "haskell" source
595+
found <- get doc pos
596+
check found targetRange
597+
598+
checkDefs defs expected = do
599+
600+
let ndef = length defs
601+
if ndef /= 1
602+
then let dfound n = "definitions found: " <> show n in
603+
liftIO $ dfound (1 :: Int) @=? dfound (length defs)
604+
else do
605+
let [Location{_range = foundRange}] = defs
606+
liftIO $ expected @=? foundRange
607+
608+
checkHover hover expected = do
609+
case hover of
610+
Nothing -> liftIO $ "hover found" @=? ("no hover found" :: T.Text)
611+
Just Hover{_contents = (HoverContents MarkupContent{_value = v})} ->
612+
liftIO $ adjust expected @=? Position l c where
613+
found = T.splitOn ":" $ head $ T.splitOn "**" $ last $ T.splitOn "Testing.hs:" v
614+
[l,c] = map (read . T.unpack) found
615+
-- looks like hovers use 1-based numbering while definitions use 0-based
616+
adjust Range{_start = Position{_line = l, _character = c}} =
617+
Position{_line = l + 1, _character = c + 1}
618+
_ -> error "test not expecting this kind of hover info"
619+
620+
source = T.unlines
621+
-- 0123456789 123456789 123456789 123456789
622+
[ "{-# OPTIONS_GHC -Wmissing-signatures #-}" -- 0
623+
, "module Testing where" -- 1
624+
, "data TypeConstructor = DataConstructor" -- 2
625+
, " { fff :: String" -- 3
626+
, " , ggg :: Int }" -- 4
627+
, "aaa :: TypeConstructor" -- 5
628+
, "aaa = DataConstructor" -- 6
629+
, " { fff = \"\"" -- 7
630+
, " , ggg = 0" -- 8
631+
, " }" -- 9
632+
-- 0123456789 123456789 123456789 123456789
633+
, "bbb :: TypeConstructor" -- 10
634+
, "bbb = DataConstructor \"\" 0" -- 11
635+
, "ccc :: (String, Int)" -- 12
636+
, "ccc = (fff bbb, ggg aaa)" -- 13
637+
, "ddd :: Num a => a -> a -> a" -- 14
638+
, "ddd vv ww = vv +! ww" -- 15
639+
, "a +! b = a - b" -- 16
640+
, "hhh (Just a) (><) = a >< a" -- 17
641+
, "iii a b = a `b` a" -- 18
642+
-- 0123456789 123456789 123456789 123456789
643+
]
644+
645+
-- definition locations
646+
tcData = mkRange 2 0 4 16
647+
tcDC = mkRange 2 23 4 16
648+
fff = mkRange 3 4 3 7
649+
aaa = mkRange 6 0 6 3
650+
vv = mkRange 15 4 15 6
651+
op = mkRange 16 2 16 4
652+
opp = mkRange 17 13 17 17
653+
apmp = mkRange 17 10 17 11
654+
bp = mkRange 18 6 18 7
655+
-- search locations
656+
fffL3 = _start fff
657+
fffL7 = Position 7 4
658+
fffL13 = Position 13 7
659+
aaaL13 = Position 13 20
660+
dcL6 = Position 6 11
661+
dcL11 = Position 11 11
662+
tcL5 = Position 5 11
663+
vvL15 = Position 15 12
664+
opL15 = Position 15 15
665+
opL17 = Position 17 22
666+
aL17 = Position 17 20
667+
b'L18 = Position 18 13
668+
669+
--t = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
670+
d = (getDefinitions, checkDefs)
671+
h = (getHover, checkHover)
672+
in
673+
testGroup "get"
674+
[ testGroup "definition"
675+
[ tst d fffL3 fff "field in record definition"
676+
, tst d fffL7 fff "field in record construction" `xfail` "known broken"
677+
, tst d fffL13 fff "field name used as accessor" -- 120 in Calculate.hs
678+
, tst d aaaL13 aaa "top-level name" -- 120
679+
, tst d dcL6 tcDC "record data constructor" `xfail` "known broken"
680+
, tst d dcL11 tcDC "plain data constructor" -- 121
681+
, tst d tcL5 tcData "type constructor" -- 147
682+
, tst d vvL15 vv "plain parameter"
683+
, tst d aL17 apmp "pattern match name"
684+
, tst d opL15 op "top-level operator" -- 123
685+
, tst d opL17 opp "parameter operator"
686+
, tst d b'L18 bp "name in backticks"
687+
]
688+
, testGroup "hover"
689+
[ tst h fffL3 fff "field in record definition"
690+
, tst h fffL7 fff "field in record construction" `xfail` "known broken"
691+
, tst h fffL13 fff "field name used as accessor" -- 120
692+
, tst h aaaL13 aaa "top-level name" -- 120
693+
, tst h dcL6 tcDC "record data constructor" `xfail` "known broken"
694+
, tst h dcL11 tcDC "plain data constructor" -- 121
695+
, tst h tcL5 tcData "type constructor" `xfail` "known broken"
696+
, tst h vvL15 vv "plain parameter"
697+
, tst h aL17 apmp "pattern match name"
698+
, tst h opL15 op "top-level operator" -- 123
699+
, tst d opL17 opp "parameter operator"
700+
, tst h b'L18 bp "name in backticks"
701+
]
702+
]
703+
704+
xfail :: TestTree -> String -> TestTree
705+
xfail = flip expectFailBecause
706+
589707
----------------------------------------------------------------------
590708
-- Utils
591709

@@ -607,6 +725,9 @@ pickActionWithTitle title actions = head
607725
| CACodeAction action@CodeAction{ _title = actionTitle } <- actions
608726
, title == actionTitle ]
609727

728+
mkRange :: Int -> Int -> Int -> Int -> Range
729+
mkRange a b c d = Range (Position a b) (Position c d)
730+
610731
run :: Session a -> IO a
611732
run s = withTempDir $ \dir -> do
612733
ghcideExe <- locateGhcideExecutable

0 commit comments

Comments
 (0)