@@ -20,6 +20,7 @@ import System.IO.Extra
2020import System.Directory
2121import Test.Tasty
2222import Test.Tasty.HUnit
23+import Test.Tasty.ExpectedFailure
2324
2425
2526main :: IO ()
@@ -31,9 +32,9 @@ main = defaultMain $ testGroup "HIE"
3132 void (message :: Session ProgressDoneNotification)
3233 , diagnosticTests
3334 , codeActionTests
35+ , findDefinitionTests
3436 ]
3537
36−
3738diagnosticTests :: TestTree
3839diagnosticTests = 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
562563addSigActionTests :: TestTree
563564addSigActionTests = 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+
610731run :: Session a -> IO a
611732run s = withTempDir $ \dir -> do
612733 ghcideExe <- locateGhcideExecutable