haskell-language-server-2.10.0.0: ghcide-test/exe/FindImplementationAndHoverTests.hs
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module FindImplementationAndHoverTests (tests) where
import Control.Monad
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Language.LSP.Test
import Text.Regex.TDFA ((=~))
import Config
import Development.IDE.Test (standardizeQuotes)
import Test.Hls
import Test.Hls.FileSystem (copyDir)
tests :: TestTree
tests = let
tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
tst (get, check) pos sfp targetRange title =
testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
doc <- openDoc sfp "haskell"
waitForProgressDone
_x <- waitForTypecheck doc
found <- get doc pos
check found targetRange
checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
checkHover hover expectations = traverse_ check =<< expectations where
check :: (HasCallStack) => Expect -> Session ()
check expected =
case hover of
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
,_range = _rangeInHover } ->
case expected of
ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet."
ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet."
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
_ -> pure () -- all other expectations not relevant to hover
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
assertFoundIn :: T.Text -> T.Text -> Assertion
assertFoundIn part whole = assertBool
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
(part `T.isInfixOf` whole)
assertNotFoundIn :: T.Text -> T.Text -> Assertion
assertNotFoundIn part whole = assertBool
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
(not . T.isInfixOf part $ whole)
sourceFilePath = T.unpack sourceFileName
sourceFileName = "GotoImplementation.hs"
mkFindTests tests = testGroup "goto implementation"
[ testGroup "implementation" $ mapMaybe fst allTests
, testGroup "hover" $ mapMaybe snd allTests
]
where
allTests = tests ++ recordDotSyntaxTests
recordDotSyntaxTests =
-- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax
[ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent"
, test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child"
, test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child"
, test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild"
]
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
test runImpl runHover look expect = testM runImpl runHover look (return expect)
testM :: (HasCallStack) => (TestTree -> a)
-> (TestTree -> b)
-> Position
-> Session [Expect]
-> String
-> (a, b)
testM = testM' sourceFilePath
test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect)
testM' :: (HasCallStack)
=> FilePath
-> (TestTree -> a)
-> (TestTree -> b)
-> Position
-> Session [Expect]
-> String
-> (a, b)
testM' sourceFile runImpl runHover look expect title =
( runImpl $ tst impl look sourceFile expect title
, runHover $ tst hover look sourceFile expect title ) where
impl = (getImplementations, checkDefs)
hover = (getHover , checkHover)
aaaL = Position 8 15; aaaR = mkRange 5 9 5 16;
aaa =
[ ExpectRanges [aaaR]
, ExpectHoverText (evidenceBoundByConstraint "Num" "AAA")
]
bbbL = Position 15 8; bbbR = mkRange 12 9 12 16;
bbb =
[ ExpectRanges [bbbR]
, ExpectHoverText (evidenceBoundByConstraint "BBB" "AAA")
]
cccL = Position 18 11;
ccc =
[ ExpectNoImplementations
, ExpectHoverText (evidenceBySignatureOrPattern "Show" "a")
]
dddShowR = mkRange 21 26 21 30; dddEqR = mkRange 21 22 21 24
dddL1 = Position 23 16;
ddd1 =
[ ExpectRanges [dddEqR]
, ExpectHoverText
[ constraintEvidence "Eq" "(Q k)"
, evidenceGoal' "'forall k. Eq k => Eq (Q k)'"
, boundByInstanceOf "Eq"
, evidenceGoal "Eq" "k"
, boundByTypeSigOrPattern
]
]
dddL2 = Position 23 29;
ddd2 =
[ ExpectNoImplementations
, ExpectHoverText (evidenceBySignatureOrPattern "Show" "k")
]
dddL3 = Position 24 8;
ddd3 =
[ ExpectRanges [dddEqR, dddShowR]
, ExpectHoverText
[ constraintEvidence "Show" "(Q Integer)"
, evidenceGoal' "'forall k. Show k => Show (Q k)'"
, boundByInstance
, evidenceGoal "Show" "Integer"
, usingExternalInstance
, constraintEvidence "Eq" "(Q Integer)"
, evidenceGoal' "'forall k. Eq k => Eq (Q k)'"
, boundByInstance
, evidenceGoal "Eq" "Integer"
, usingExternalInstance
]
]
gadtL = Position 29 35;
gadt =
[ ExpectNoImplementations
, ExpectHoverText
[ constraintEvidence "Show" "Int"
, evidenceGoal "Show" "a"
, boundByTypeSigOrPattern
, evidenceGoal' "'a ~ Int'"
, boundByPattern
]
]
in
mkFindTests
-- impl hover look expect
[
test yes yes aaaL aaa "locally defined class instance"
, test yes yes bbbL bbb "locally defined class and instance"
, test yes yes cccL ccc "bound by type signature"
, test yes yes dddL1 ddd1 "newtype Eq evidence"
, test yes yes dddL2 ddd2 "Show evidence"
, test yes yes dddL3 ddd3 "evidence construction"
, test yes yes gadtL gadt "GADT evidence"
]
where yes :: (TestTree -> Maybe TestTree)
yes = Just -- test should run and pass
no = const Nothing -- don't run this test at all
-- ----------------------------------------------------------------------------
-- Helper functions for creating hover message verification
-- ----------------------------------------------------------------------------
evidenceBySignatureOrPattern :: Text -> Text -> [Text]
evidenceBySignatureOrPattern tyclass varname =
[ constraintEvidence tyclass varname
, boundByTypeSigOrPattern
]
evidenceBoundByConstraint :: Text -> Text -> [Text]
evidenceBoundByConstraint tyclass varname =
[ constraintEvidence tyclass varname
, boundByInstanceOf tyclass
]
boundByTypeSigOrPattern :: Text
boundByTypeSigOrPattern = "bound by type signature or pattern"
boundByInstance :: Text
boundByInstance =
"bound by an instance of"
boundByInstanceOf :: Text -> Text
boundByInstanceOf tyvar =
"bound by an instance of class " <> tyvar
boundByPattern :: Text
boundByPattern =
"bound by a pattern"
usingExternalInstance :: Text
usingExternalInstance =
"using an external instance"
constraintEvidence :: Text -> Text -> Text
constraintEvidence tyclass varname = "Evidence of constraint " <> quotedName tyclass varname
-- | A goal in the evidence tree.
evidenceGoal :: Text -> Text -> Text
evidenceGoal tyclass varname = "- " <> quotedName tyclass varname
evidenceGoal' :: Text -> Text
evidenceGoal' t = "- " <> t
quotedName :: Text -> Text -> Text
quotedName tyclass varname = "'" <> tyclass <> " " <> varname <> "'"