@@ -38,7 +38,7 @@ main = defaultMain $ testGroup "HIE"
3838 , initializeResponseTests
3939 , diagnosticTests
4040 , codeActionTests
41− , findDefinitionTests
41+ , findDefinitionAndHoverTests
4242 ]
4343
4444initializeResponseTests :: TestTree
@@ -690,66 +690,86 @@ addSigActionTests = let
690690 , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
691691 ]
692692
693−findDefinitionTests :: TestTree
694−findDefinitionTests = let
693+findDefinitionAndHoverTests :: TestTree
694+findDefinitionAndHoverTests = let
695695
696696 tst (get, check) pos targetRange title = testSession title $ do
697− doc <- openDoc' "Testing.hs" "haskell" source
697+ doc <- openDoc' sourceFilePath "haskell" source
698698 found <- get doc pos
699699 check found targetRange
700700
701− checkDefs defs expected = do
702−
703− let ndef = length defs
704− if ndef /= 1
705− then let dfound n = "definitions found: " <> show n in
706− liftIO $ dfound (1 :: Int) @=? dfound (length defs)
707− else do
708− let [Location{_range = foundRange}] = defs
709− liftIO $ expected @=? foundRange
710−
711− checkHover hover expected =
712− case hover of
713− Nothing -> liftIO $ "hover found" @=? ("no hover found" :: T.Text)
714− Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
715− ,_range = mRange } ->
716− let
717− extractLineColFromMsg =
718− T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn "Testing.hs:"
719− lineCol = extractLineColFromMsg msg
720−
721− -- looks like hovers use 1-based numbering while definitions use 0-based
722− -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
723− adjust Position{_line = l, _character = c} =
724− Position{_line = l + 1, _character = c + 1}
725− in
726− case lineCol of
727− [_,_] -> liftIO $ (adjust $ _start expected) @=? Position l c where [l,c] = map (read . T.unpack) lineCol
728− _ -> liftIO $ ("[...]Testing.hs:<LINE>:<COL>**[...]", mRange) @=? (msg, Just expected)
729− _ -> error "test not expecting this kind of hover info"
701+ checkDefs :: [Location] -> [Expect] -> Session ()
702+ checkDefs defs expectations = traverse_ check expectations where
703+
704+ check (ExpectRange expectedRange) = do
705+ assertNDefinitionsFound 1 defs
706+ assertRangeCorrect (head defs) expectedRange
707+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
708+ check _ = pure () -- all other expectations not relevant to getDefinition
709+
710+ assertNDefinitionsFound :: Int -> [a] -> Session ()
711+ assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
712+
713+ assertRangeCorrect Location{_range = foundRange} expectedRange =
714+ liftIO $ expectedRange @=? foundRange
715+
716+ checkHover :: Maybe Hover -> [Expect] -> Session ()
717+ checkHover hover expectations = traverse_ check expectations where
718+
719+ check expected =
720+ case hover of
721+ Nothing -> liftIO $ assertFailure "no hover found"
722+ Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
723+ ,_range = rangeInHover } ->
724+ case expected of
725+ ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
726+ ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
727+ ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
728+ _ -> pure () -- all other expectations not relevant to hover
729+ _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
730+
731+ extractLineColFromHoverMsg :: T.Text -> [T.Text]
732+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")
733+
734+ checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
735+ checkHoverRange expectedRange rangeInHover msg =
736+ let
737+ lineCol = extractLineColFromHoverMsg msg
738+ -- looks like hovers use 1-based numbering while definitions use 0-based
739+ -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
740+ adjust Position{_line = l, _character = c} =
741+ Position{_line = l + 1, _character = c + 1}
742+ in
743+ case map (read . T.unpack) lineCol of
744+ [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c
745+ _ -> liftIO $ assertFailure $
746+ "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
747+ "\n but got: " <> show (msg, rangeInHover)
748+
749+ assertFoundIn :: T.Text -> T.Text -> Assertion
750+ assertFoundIn part whole = assertBool
751+ (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
752+ (part `T.isInfixOf` whole)
753+
754+ sourceFilePath = "Testing.hs" -- TODO: convert from sourceFileName
755+ sourceFileName = "Testing.hs"
730756
731757 mkFindTests tests = testGroup "get"
732758 [ testGroup "definition" $ mapMaybe fst tests
733759 , testGroup "hover" $ mapMaybe snd tests ]
734760
735− test runDef runHover look bind title =
736− ( runDef $ tst def look bind title
737− , runHover $ tst hover look bind title ) where
761+ test runDef runHover look expect title =
762+ ( runDef $ tst def look expect title
763+ , runHover $ tst hover look expect title ) where
738764 def = (getDefinitions, checkDefs)
739765 hover = (getHover , checkHover)
740766 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
741− -- test run control
742− yes, broken :: (TestTree -> Maybe TestTree)
743− yes = Just -- test should run and pass
744− broken = Just . (`xfail` "known broken")
745− cant = Just . (`xfail` "cannot be made to work")
746−-- no = const Nothing -- don't run this test at all
747767
748768 source = T.unlines
749769 -- 0123456789 123456789 123456789 123456789
750770 [ "{-# OPTIONS_GHC -Wmissing-signatures #-}" -- 0
751771 , "module Testing where" -- 1
752− , "import Data.Text (Text)" -- 2
772+ , "import Data.Text (Text, pack)" -- 2
753773 , "data TypeConstructor = DataConstructor" -- 3
754774 , " { fff :: Text" -- 4
755775 , " , ggg :: Int }" -- 5
@@ -768,27 +788,29 @@ findDefinitionTests = let
768788 , "a +! b = a - b" -- 17
769789 , "hhh (Just a) (><) = a >< a" -- 18
770790 , "iii a b = a `b` a" -- 19
791+ , "jjj s = pack $ s <> s" -- 20
771792 -- 0123456789 123456789 123456789 123456789
772793 ]
773794
774− -- search locations definition locations
775− fffL4 = _start fff ; fff = mkRange 4 4 4 7
795+ -- search locations expectations on results
796+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
776797 fffL8 = Position 8 4 ;
777798 fffL14 = Position 14 7 ;
778− aaaL14 = Position 14 20 ; aaa = mkRange 7 0 7 3
779− dcL7 = Position 7 11 ; tcDC = mkRange 3 23 5 16
799+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
800+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
780801 dcL12 = Position 12 11 ;
781− xtcL5 = Position 5 11 ; xtc = undefined -- not clear what it should do
782− tcL6 = Position 6 11 ; tcData = mkRange 3 0 5 16
783− vvL16 = Position 16 12 ; vv = mkRange 16 4 16 6
784− opL16 = Position 16 15 ; op = mkRange 17 2 17 4
785− opL18 = Position 18 22 ; opp = mkRange 18 13 18 17
786− aL18 = Position 18 20 ; apmp = mkRange 18 10 18 11
787− b'L19 = Position 19 13 ; bp = mkRange 19 6 19 7
802+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail]
803+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16]
804+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
805+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
806+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
807+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
808+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
809+ xvL20 = Position 20 8 ; xvMsg = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]
788810
789811 in
790812 mkFindTests
791− -- def hover look bind
813+ -- def hover look expect
792814 [ test yes yes fffL4 fff "field in record definition"
793815 , test broken broken fffL8 fff "field in record construction"
794816 , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
@@ -796,17 +818,32 @@ findDefinitionTests = let
796818 , test broken broken dcL7 tcDC "record data constructor"
797819 , test yes yes dcL12 tcDC "plain data constructor" -- 121
798820 , test yes broken tcL6 tcData "type constructor" -- 147
799− , test cant broken xtcL5 xtc "type constructor from other package"
821+ , test broken broken xtcL5 xtc "type constructor from other package"
822+ , test broken yes xvL20 xvMsg "value from other package"
800823 , test yes yes vvL16 vv "plain parameter"
801824 , test yes yes aL18 apmp "pattern match name"
802825 , test yes yes opL16 op "top-level operator" -- 123
803826 , test yes yes opL18 opp "parameter operator"
804827 , test yes yes b'L19 bp "name in backticks"
805828 ]
829+ where yes, broken :: (TestTree -> Maybe TestTree)
830+ yes = Just -- test should run and pass
831+ broken = Just . (`xfail` "known broken")
832+ -- no = const Nothing -- don't run this test at all
806833
807834xfail :: TestTree -> String -> TestTree
808835xfail = flip expectFailBecause
809836
837+data Expect
838+ = ExpectRange Range -- Both gotoDef and hover should report this range
839+-- | ExpectDefRange Range -- Only gotoDef should report this range
840+ | ExpectHoverRange Range -- Only hover should report this range
841+ | ExpectHoverText [T.Text] -- the hover message must contain these snippets
842+ | ExpectExternFail -- definition lookup in other file expected to fail
843+-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
844+
845+mkR :: Int -> Int -> Int -> Int -> Expect
846+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
810847----------------------------------------------------------------------
811848-- Utils
812849