@@ -20,6 +20,7 @@ import System.IO.Extra
20
20
import System.Directory
21
21
import Test.Tasty
22
22
import Test.Tasty.HUnit
23
+ import Test.Tasty.ExpectedFailure
23
24
24
25
25
26
main :: IO ()
@@ -31,9 +32,9 @@ main = defaultMain $ testGroup "HIE"
31
32
void (message :: Session ProgressDoneNotification )
32
33
, diagnosticTests
33
34
, codeActionTests
35
+ , findDefinitionTests
34
36
]
35
37
36
-
37
38
diagnosticTests :: TestTree
38
39
diagnosticTests = testGroup " diagnostics"
39
40
[ testSession " fix syntax error" $ do
@@ -113,10 +114,10 @@ diagnosticTests = testGroup "diagnostics"
113
114
expectedDs aMessage =
114
115
[ (" A.hs" , [(DsError , (2 ,4 ), aMessage)])
115
116
, (" B.hs" , [(DsError , (3 ,4 ), bMessage)])]
116
- deferralTest title binding message = testSession title $ do
117
+ deferralTest title binding msg = testSession title $ do
117
118
_ <- openDoc' " A.hs" " haskell" $ sourceA binding
118
119
_ <- openDoc' " B.hs" " haskell" sourceB
119
- expectDiagnostics $ expectedDs message
120
+ expectDiagnostics $ expectedDs msg
120
121
in
121
122
[ deferralTest " type error" " True" " Couldn't match expected type"
122
123
, deferralTest " typed hole" " _" " Found hole"
@@ -561,14 +562,14 @@ fillTypedHoleTests = let
561
562
562
563
addSigActionTests :: TestTree
563
564
addSigActionTests = let
564
- head = T. unlines [ " {-# OPTIONS_GHC -Wmissing-signatures #-}"
565
+ header = T. unlines [ " {-# OPTIONS_GHC -Wmissing-signatures #-}"
565
566
, " 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]
568
569
569
570
def >:: sig = testSession (T. unpack def) $ do
570
571
let originalCode = before def
571
- let expectedCode = after def sig
572
+ let expectedCode = after' def sig
572
573
doc <- openDoc' " Sigs.hs" " haskell" originalCode
573
574
_ <- waitForDiagnostics
574
575
actionsOrCommands <- getCodeActions doc (Range (Position 3 1 ) (Position 3 maxBound ))
@@ -586,6 +587,123 @@ addSigActionTests = let
586
587
, " a `haha` b = a b" >:: " haha :: (t1 -> t2) -> t1 -> t2"
587
588
]
588
589
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
+
589
707
----------------------------------------------------------------------
590
708
-- Utils
591
709
@@ -607,6 +725,9 @@ pickActionWithTitle title actions = head
607
725
| CACodeAction action@ CodeAction { _title = actionTitle } <- actions
608
726
, title == actionTitle ]
609
727
728
+ mkRange :: Int -> Int -> Int -> Int -> Range
729
+ mkRange a b c d = Range (Position a b) (Position c d)
730
+
610
731
run :: Session a -> IO a
611
732
run s = withTempDir $ \ dir -> do
612
733
ghcideExe <- locateGhcideExecutable
0 commit comments