Skip to content

Commit 75cb0b9

Browse files
soulomoonsoulomoon
authored
Migrate FindDefinitionAndHoverTests and HighlightTests part of #4173 and fix HighlightTests (#4202)
* migrate FindDefinitionAndHoverTests * migrate highlighttests * fix highlight
1 parent 877e75c commit 75cb0b9

File tree

8 files changed

+123
-111
lines changed

8 files changed

+123
-111
lines changed

‎ghcide/src/Development/IDE/GHC/Compat.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ module Development.IDE.GHC.Compat(
3838
mkFastStringByteString,
3939
nodeInfo',
4040
getNodeIds,
41+
getSourceNodeIds,
4142
sourceNodeInfo,
4243
generatedNodeInfo,
4344
simpleNodeInfoCompat,
@@ -471,7 +472,9 @@ isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False
471472
isQualifiedImport ImportDecl{} = True
472473
isQualifiedImport _ = False
473474

474-
475+
-- | Like getNodeIds but with generated node removed
476+
getSourceNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)
477+
getSourceNodeIds = Map.foldl' combineNodeIds Map.empty . Map.filterWithKey (\k _ -> k == SourceInfo) . getSourcedNodeInfo . sourcedNodeInfo
475478

476479
getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)
477480
getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo

‎ghcide/src/Development/IDE/Spans/AtPoint.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ import Data.List (isSuffixOf)
5656
import Data.List.Extra (dropEnd1, nubOrd)
5757

5858
import Data.Version (showVersion)
59+
import Development.IDE.GHC.Compat (getSourceNodeIds)
5960
import Development.IDE.Types.Shake (WithHieDb)
6061
import HieDb hiding (pointCommand,
6162
withHieDb)
@@ -167,7 +168,7 @@ documentHighlight hf rf pos = pure highlights
167168
where
168169
-- We don't want to show document highlights for evidence variables, which are supposed to be invisible
169170
notEvidence = not . any isEvidenceContext . identInfo
170-
ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds)
171+
ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getSourceNodeIds)
171172
highlights = do
172173
n <- ns
173174
ref <- fromMaybe [] (M.lookup (Right n) rf)

‎ghcide/test/exe/BootTests.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module BootTests (tests) where
22

3+
import Config (checkDefs, mkR)
34
import Control.Applicative.Combinators
45
import Control.Monad
56
import Control.Monad.IO.Class (liftIO)

‎ghcide/test/exe/Config.hs‎

Lines changed: 68 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,15 @@
22

33
module Config where
44

5-
import Ide.Types (defaultPluginDescriptor)
6-
import System.FilePath ((</>))
5+
import Data.Foldable (traverse_)
6+
import qualified Data.Text as T
7+
import Development.IDE.Test (canonicalizeUri)
8+
import Ide.Types (defaultPluginDescriptor)
9+
import Language.LSP.Protocol.Types (Null (..))
10+
import System.FilePath ((</>))
711
import Test.Hls
8-
import qualified Test.Hls.FileSystem as FS
9-
import Test.Hls.FileSystem (FileSystem)
12+
import qualified Test.Hls.FileSystem as FS
13+
import Test.Hls.FileSystem (FileSystem)
1014

1115
testDataDir :: FilePath
1216
testDataDir = "ghcide" </> "test" </> "data"
@@ -24,6 +28,12 @@ runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin
2428
runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a
2529
runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin
2630

31+
runWithDummyPluginAndCap :: ClientCapabilities -> Session () -> IO ()
32+
runWithDummyPluginAndCap cap = runSessionWithServerAndCapsInTmpDir def dummyPlugin cap (mkIdeTestFs [])
33+
34+
testWithDummyPluginAndCap :: String -> ClientCapabilities -> Session () -> TestTree
35+
testWithDummyPluginAndCap caseName cap = testCase caseName . runWithDummyPluginAndCap cap
36+
2737
-- testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree
2838
testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree
2939
testWithDummyPlugin caseName vfs = testCase caseName . runWithDummyPlugin vfs
@@ -50,3 +60,57 @@ testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFil
5060

5161
pattern R :: UInt -> UInt -> UInt -> UInt -> Range
5262
pattern R x y x' y' = Range (Position x y) (Position x' y')
63+
64+
data Expect
65+
= ExpectRange Range -- Both gotoDef and hover should report this range
66+
| ExpectLocation Location
67+
-- | ExpectDefRange Range -- Only gotoDef should report this range
68+
| ExpectHoverRange Range -- Only hover should report this range
69+
| ExpectHoverText [T.Text] -- the hover message must contain these snippets
70+
| ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets
71+
| ExpectHoverTextRegex T.Text -- the hover message must match this pattern
72+
| ExpectExternFail -- definition lookup in other file expected to fail
73+
| ExpectNoDefinitions
74+
| ExpectNoHover
75+
-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
76+
deriving Eq
77+
78+
mkR :: UInt -> UInt -> UInt -> UInt -> Expect
79+
mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
80+
81+
mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect
82+
mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
83+
84+
85+
checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()
86+
checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where
87+
check (ExpectRange expectedRange) = do
88+
def <- assertOneDefinitionFound defs
89+
assertRangeCorrect def expectedRange
90+
check (ExpectLocation expectedLocation) = do
91+
def <- assertOneDefinitionFound defs
92+
liftIO $ do
93+
canonActualLoc <- canonicalizeLocation def
94+
canonExpectedLoc <- canonicalizeLocation expectedLocation
95+
canonActualLoc @?= canonExpectedLoc
96+
check ExpectNoDefinitions = do
97+
liftIO $ assertBool "Expecting no definitions" $ null defs
98+
check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
99+
check _ = pure () -- all other expectations not relevant to getDefinition
100+
101+
assertOneDefinitionFound :: [Location] -> Session Location
102+
assertOneDefinitionFound [def] = pure def
103+
assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)
104+
105+
assertRangeCorrect Location{_range = foundRange} expectedRange =
106+
liftIO $ expectedRange @=? foundRange
107+
108+
109+
canonicalizeLocation :: Location -> IO Location
110+
canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
111+
112+
defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]
113+
defToLocation (InL (Definition (InL l))) = [l]
114+
defToLocation (InL (Definition (InR ls))) = ls
115+
defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink
116+
defToLocation (InR (InR Null)) = []

‎ghcide/test/exe/CradleTests.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Language.LSP.Test
2525
import System.FilePath
2626
import System.IO.Extra hiding (withTempDir)
2727
-- import Test.QuickCheck.Instances ()
28+
import Config (checkDefs, mkL)
2829
import Control.Lens ((^.))
2930
import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..))
3031
import GHC.TypeLits (symbolVal)

‎ghcide/test/exe/FindDefinitionAndHoverTests.hs‎

Lines changed: 41 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -1,56 +1,49 @@
1+
{-# LANGUAGE ExplicitNamespaces #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE ViewPatterns #-}
14

25
module FindDefinitionAndHoverTests (tests) where
36

47
import Control.Monad
5-
import Control.Monad.IO.Class (liftIO)
68
import Data.Foldable
79
import Data.Maybe
8-
import qualified Data.Text as T
9-
import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion)
10-
import Development.IDE.GHC.Util
11-
import Development.IDE.Test (expectDiagnostics,
12-
standardizeQuotes)
13-
import Development.IDE.Types.Location
14-
import qualified Language.LSP.Protocol.Lens as L
15-
import Language.LSP.Protocol.Types hiding
16-
(SemanticTokenAbsolute (..),
17-
SemanticTokenRelative (..),
18-
SemanticTokensEdit (..),
19-
mkRange)
10+
import qualified Data.Text as T
11+
import qualified Language.LSP.Protocol.Lens as L
2012
import Language.LSP.Test
21-
import System.FilePath
22-
import System.Info.Extra (isWindows)
13+
import System.Info.Extra (isWindows)
2314

24-
import Control.Lens ((^.))
15+
import Control.Lens ((^.))
2516
import Test.Tasty
2617
import Test.Tasty.HUnit
27-
import TestUtils
28-
import Text.Regex.TDFA ((=~))
18+
-- import TestUtils
19+
import Config
20+
import Debug.Trace (traceM)
21+
import Development.IDE (readFileUtf8)
22+
import Development.IDE.Test (expectDiagnostics,
23+
standardizeQuotes)
24+
import System.Directory (copyFile)
25+
import System.FilePath ((</>))
26+
import Test.Hls
27+
import Test.Hls.FileSystem (copy, copyDir, file, toAbsFp)
28+
import Text.Regex.TDFA ((=~))
2929

3030
tests :: TestTree
3131
tests = let
32-
3332
tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
34-
tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
35-
36-
-- Dirty the cache to check that definitions work even in the presence of iface files
37-
liftIO $ runInDir dir $ do
38-
let fooPath = dir </> "Foo.hs"
39-
fooSource <- liftIO $ readFileUtf8 fooPath
40-
fooDoc <- createDoc fooPath "haskell" fooSource
41-
_ <- getHover fooDoc $ Position 4 3
42-
closeDoc fooDoc
33+
tst (get, check) pos sfp targetRange title =
34+
testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
35+
doc <- openDoc sfp "haskell"
36+
waitForProgressDone
37+
_x <- waitForTypecheck doc
38+
found <- get doc pos
39+
check found targetRange
4340

44-
doc <- openTestDataDoc (dir </> sfp)
45-
waitForProgressDone
46-
found <- get doc pos
47-
check found targetRange
4841

4942

50-
51-
checkHover :: Maybe Hover -> Session [Expect] -> Session ()
43+
checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
5244
checkHover hover expectations = traverse_ check =<< expectations where
5345

46+
check :: (HasCallStack) => Expect -> Session ()
5447
check expected =
5548
case hover of
5649
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
@@ -100,11 +93,11 @@ tests = let
10093
mkFindTests tests = testGroup "get"
10194
[ testGroup "definition" $ mapMaybe fst tests
10295
, testGroup "hover" $ mapMaybe snd tests
103-
, checkFileCompiles sourceFilePath $
96+
, testGroup "hover compile" [checkFileCompiles sourceFilePath $
10497
expectDiagnostics
10598
[ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])
10699
, ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])
107-
]
100+
]]
108101
, testGroup "type-definition" typeDefinitionTests
109102
, testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]
110103

@@ -117,8 +110,15 @@ tests = let
117110
, tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
118111
]
119112

113+
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
120114
test runDef runHover look expect = testM runDef runHover look (return expect)
121115

116+
testM :: (HasCallStack) => (TestTree -> a)
117+
-> (TestTree -> b)
118+
-> Position
119+
-> Session [Expect]
120+
-> String
121+
-> (a, b)
122122
testM runDef runHover look expect title =
123123
( runDef $ tst def look sourceFilePath expect title
124124
, runHover $ tst hover look sourceFilePath expect title ) where
@@ -228,8 +228,11 @@ tests = let
228228
no = const Nothing -- don't run this test at all
229229
--skip = const Nothing -- unreliable, don't run
230230

231+
xfail :: TestTree -> String -> TestTree
232+
xfail = flip expectFailBecause
233+
231234
checkFileCompiles :: FilePath -> Session () -> TestTree
232235
checkFileCompiles fp diag =
233-
testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
234-
void (openTestDataDoc (dir </> fp))
236+
testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do
237+
_ <- openDoc fp "haskell"
235238
diag

‎ghcide/test/exe/HighlightTests.hs‎

Lines changed: 6 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11

22
module HighlightTests (tests) where
33

4+
import Config
45
import Control.Monad.IO.Class (liftIO)
56
import qualified Data.Text as T
6-
import Development.IDE.GHC.Compat (GhcVersion (..))
77
import Development.IDE.Types.Location
88
import Language.LSP.Protocol.Types hiding
99
(SemanticTokenAbsolute (..),
@@ -13,11 +13,10 @@ import Language.LSP.Protocol.Types hiding
1313
import Language.LSP.Test
1414
import Test.Tasty
1515
import Test.Tasty.HUnit
16-
import TestUtils
1716

1817
tests :: TestTree
1918
tests = testGroup "highlight"
20-
[ testSessionWait "value" $ do
19+
[ testWithDummyPluginEmpty "value" $ do
2120
doc <- createDoc "A.hs" "haskell" source
2221
_ <- waitForDiagnostics
2322
highlights <- getHighlights doc (Position 3 2)
@@ -27,15 +26,15 @@ tests = testGroup "highlight"
2726
, DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)
2827
, DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)
2928
]
30-
, testSessionWait "type" $ do
29+
, testWithDummyPluginEmpty "type" $ do
3130
doc <- createDoc "A.hs" "haskell" source
3231
_ <- waitForDiagnostics
3332
highlights <- getHighlights doc (Position 2 8)
3433
liftIO $ highlights @?=
3534
[ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)
3635
, DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)
3736
]
38-
, testSessionWait "local" $ do
37+
, testWithDummyPluginEmpty "local" $ do
3938
doc <- createDoc "A.hs" "haskell" source
4039
_ <- waitForDiagnostics
4140
highlights <- getHighlights doc (Position 6 5)
@@ -44,8 +43,8 @@ tests = testGroup "highlight"
4443
, DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read)
4544
, DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)
4645
]
47-
, knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $
48-
testSessionWait "record" $ do
46+
,
47+
testWithDummyPluginEmpty "record" $ do
4948
doc <- createDoc "A.hs" "haskell" recsource
5049
_ <- waitForDiagnostics
5150
highlights <- getHighlights doc (Position 4 15)

‎ghcide/test/exe/TestUtils.hs‎

Lines changed: 0 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -206,26 +206,6 @@ knownIssueFor solution = go . \case
206206
Ignore -> ignoreTestBecause
207207
go False = const id
208208

209-
data Expect
210-
= ExpectRange Range -- Both gotoDef and hover should report this range
211-
| ExpectLocation Location
212-
-- | ExpectDefRange Range -- Only gotoDef should report this range
213-
| ExpectHoverRange Range -- Only hover should report this range
214-
| ExpectHoverText [T.Text] -- the hover message must contain these snippets
215-
| ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets
216-
| ExpectHoverTextRegex T.Text -- the hover message must match this pattern
217-
| ExpectExternFail -- definition lookup in other file expected to fail
218-
| ExpectNoDefinitions
219-
| ExpectNoHover
220-
-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
221-
deriving Eq
222-
223-
mkR :: UInt -> UInt -> UInt -> UInt -> Expect
224-
mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
225-
226-
mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect
227-
mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
228-
229209

230210

231211
testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
@@ -261,46 +241,6 @@ withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIME
261241
lspTestCapsNoFileWatches :: ClientCapabilities
262242
lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing
263243

264-
openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
265-
openTestDataDoc path = do
266-
source <- liftIO $ readFileUtf8 $ "ghcide/test/data" </> path
267-
createDoc path "haskell" source
268-
269-
pattern R :: UInt -> UInt -> UInt -> UInt -> Range
270-
pattern R x y x' y' = Range (Position x y) (Position x' y')
271-
272-
checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()
273-
checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where
274-
check (ExpectRange expectedRange) = do
275-
def <- assertOneDefinitionFound defs
276-
assertRangeCorrect def expectedRange
277-
check (ExpectLocation expectedLocation) = do
278-
def <- assertOneDefinitionFound defs
279-
liftIO $ do
280-
canonActualLoc <- canonicalizeLocation def
281-
canonExpectedLoc <- canonicalizeLocation expectedLocation
282-
canonActualLoc @?= canonExpectedLoc
283-
check ExpectNoDefinitions = do
284-
liftIO $ assertBool "Expecting no definitions" $ null defs
285-
check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
286-
check _ = pure () -- all other expectations not relevant to getDefinition
287-
288-
assertOneDefinitionFound :: [Location] -> Session Location
289-
assertOneDefinitionFound [def] = pure def
290-
assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)
291-
292-
assertRangeCorrect Location{_range = foundRange} expectedRange =
293-
liftIO $ expectedRange @=? foundRange
294-
295-
canonicalizeLocation :: Location -> IO Location
296-
canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
297-
298-
defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]
299-
defToLocation (InL (Definition (InL l))) = [l]
300-
defToLocation (InL (Definition (InR ls))) = ls
301-
defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink
302-
defToLocation (InR (InR Null)) = []
303-
304244
testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()
305245
testIde recorder arguments session = do
306246
config <- getConfigFromEnv

0 commit comments

Comments
 (0)