@@ -21,7 +21,7 @@ import System.Directory
2121import Test.Tasty
2222import Test.Tasty.HUnit
2323import Test.Tasty.ExpectedFailure
24−
24+import Data.Maybe
2525
2626main :: IO ()
2727main = defaultMain $ testGroup "HIE"
@@ -605,18 +605,42 @@ findDefinitionTests = let
605605 let [Location{_range = foundRange}] = defs
606606 liftIO $ expected @=? foundRange
607607
608− checkHover hover expected = do
608+ checkHover hover expected =
609609 case hover of
610610 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
611+ Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
612+ ,_range = mRange } ->
613+ let
614+ extractLineColFromMsg =
615+ T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn "Testing.hs:"
616+ lineCol = extractLineColFromMsg msg
617+
615618 -- looks like hovers use 1-based numbering while definitions use 0-based
616− adjust Range{_start = Position{_line = l, _character = c}} =
619+ -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
620+ adjust Position{_line = l, _character = c} =
617621 Position{_line = l + 1, _character = c + 1}
622+ in
623+ case lineCol of
624+ [_,_] -> liftIO $ (adjust $ _start expected) @=? Position l c where [l,c] = map (read . T.unpack) lineCol
625+ _ -> liftIO $ ("[...]Testing.hs:<LINE>:<COL>**[...]", mRange) @=? (msg, Just expected)
618626 _ -> error "test not expecting this kind of hover info"
619627
628+ mkFindTests tests = testGroup "get"
629+ [ testGroup "definition" $ mapMaybe fst tests
630+ , testGroup "hover" $ mapMaybe snd tests ]
631+
632+ test runDef runHover look bind title =
633+ ( runDef $ tst def look bind title
634+ , runHover $ tst hover look bind title ) where
635+ def = (getDefinitions, checkDefs)
636+ hover = (getHover , checkHover)
637+ --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
638+ -- test run control
639+ yes, broken :: (TestTree -> Maybe TestTree)
640+ yes = Just -- test should run and pass
641+ broken = Just . (`xfail` "known broken")
642+-- no = const Nothing -- don't run this test at all
643+
620644 source = T.unlines
621645 -- 0123456789 123456789 123456789 123456789
622646 [ "{-# OPTIONS_GHC -Wmissing-signatures #-}" -- 0
@@ -642,63 +666,35 @@ findDefinitionTests = let
642666 -- 0123456789 123456789 123456789 123456789
643667 ]
644668
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)
669+ -- search locations definition locations
670+ fffL3 = _start fff ; fff = mkRange 3 4 3 7
671+ fffL7 = Position 7 4 ;
672+ fffL13 = Position 13 7 ;
673+ aaaL13 = Position 13 20 ; aaa = mkRange 6 0 6 3
674+ dcL6 = Position 6 11 ; tcDC = mkRange 2 23 4 16
675+ dcL11 = Position 11 11 ;
676+ tcL5 = Position 5 11 ; tcData = mkRange 2 0 4 16
677+ vvL15 = Position 15 12 ; vv = mkRange 15 4 15 6
678+ opL15 = Position 15 15 ; op = mkRange 16 2 16 4
679+ opL17 = Position 17 22 ; opp = mkRange 17 13 17 17
680+ aL17 = Position 17 20 ; apmp = mkRange 17 10 17 11
681+ b'L18 = Position 18 13 ; bp = mkRange 18 6 18 7
682+
672683 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− ]
684+ mkFindTests
685+ -- def hover look bind
686+ [ test yes yes fffL3 fff "field in record definition"
687+ , test broken broken fffL7 fff "field in record construction"
688+ , test yes yes fffL13 fff "field name used as accessor" -- 120 in Calculate.hs
689+ , test yes yes aaaL13 aaa "top-level name" -- 120
690+ , test broken broken dcL6 tcDC "record data constructor"
691+ , test yes yes dcL11 tcDC "plain data constructor" -- 121
692+ , test yes broken tcL5 tcData "type constructor" -- 147
693+ , test yes yes vvL15 vv "plain parameter"
694+ , test yes yes aL17 apmp "pattern match name"
695+ , test yes yes opL15 op "top-level operator" -- 123
696+ , test yes yes opL17 opp "parameter operator"
697+ , test yes yes b'L18 bp "name in backticks"
702698 ]
703699
704700xfail :: TestTree -> String -> TestTree