Skip to content

Commit 59b8da7

Browse files
fendorfendor
committed
Generalize hover test assertions
1 parent c543621 commit 59b8da7

3 files changed

Lines changed: 83 additions & 81 deletions

File tree

‎.hlint.yaml‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -161,8 +161,7 @@
161161
- Ide.PluginUtils
162162
- Ide.Plugin.Eval.Parse.Comments
163163
- Ide.Plugin.Eval.CodeLens
164-
- FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests
165-
- FindImplementationAndHoverTests #Previously part of GHCIDE Main tests
164+
- Hover #Used for tests that are allowed to crash
166165

167166
- name: [Prelude.init, Data.List.init]
168167
within:

‎ghcide-test/exe/FindDefinitionAndHoverTests.hs‎

Lines changed: 8 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -1,26 +1,19 @@
11
{-# LANGUAGE ExplicitNamespaces #-}
22
{-# LANGUAGE OverloadedStrings #-}
3-
{-# LANGUAGE ViewPatterns #-}
43

54
module FindDefinitionAndHoverTests (tests) where
65

7-
import Control.Monad
8-
import Data.Foldable
6+
import Config
7+
import Control.Lens ((^.))
98
import Data.Maybe
109
import qualified Data.Text as T
10+
import Development.IDE.Test (expectDiagnostics)
11+
import Hover
1112
import qualified Language.LSP.Protocol.Lens as L
1213
import Language.LSP.Test
1314
import System.Info.Extra (isWindows)
14-
15-
import Config
16-
import Control.Category ((>>>))
17-
import Control.Lens ((^.))
18-
import Development.IDE.Test (expectDiagnostics,
19-
standardizeQuotes)
20-
import Hover
2115
import Test.Hls
2216
import Test.Hls.FileSystem (copyDir)
23-
import Text.Regex.TDFA ((=~))
2417

2518
tests :: TestTree
2619
tests = let
@@ -34,64 +27,6 @@ tests = let
3427
check found targetRange
3528

3629

37-
38-
checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
39-
checkHover hover expectations = traverse_ check =<< expectations where
40-
41-
check :: (HasCallStack) => Expect -> Session ()
42-
check expected =
43-
case hover of
44-
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
45-
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
46-
,_range = rangeInHover } ->
47-
case expected of
48-
ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
49-
ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
50-
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
51-
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
52-
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
53-
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
54-
_ -> pure () -- all other expectations not relevant to hover
55-
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
56-
57-
extractLineColFromHoverMsg :: T.Text -> [T.Text]
58-
extractLineColFromHoverMsg =
59-
-- Hover messages contain multiple lines, and we are looking for the definition
60-
-- site
61-
T.lines
62-
-- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*"
63-
-- So filter by the start of the line
64-
>>> mapMaybe (T.stripPrefix "*Defined at")
65-
-- There can be multiple definitions per hover message!
66-
-- See the test "field in record definition" for example.
67-
-- The tests check against the last line that contains the above line.
68-
>>> last
69-
-- [" /tmp/", "22:3*"]
70-
>>> T.splitOn (sourceFileName <> ":")
71-
-- "22:3*"
72-
>>> last
73-
-- ["22:3", ""]
74-
>>> T.splitOn "*"
75-
-- "22:3"
76-
>>> head
77-
-- ["22", "3"]
78-
>>> T.splitOn ":"
79-
80-
checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
81-
checkHoverRange expectedRange rangeInHover msg =
82-
let
83-
lineCol = extractLineColFromHoverMsg msg
84-
-- looks like hovers use 1-based numbering while definitions use 0-based
85-
-- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
86-
adjust Position{_line = l, _character = c} =
87-
Position{_line = l + 1, _character = c + 1}
88-
in
89-
case map (read . T.unpack) lineCol of
90-
[l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c
91-
_ -> liftIO $ assertFailure $
92-
"expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
93-
"\n but got: " <> show (msg, rangeInHover)
94-
9530
sourceFilePath = T.unpack sourceFileName
9631
sourceFileName = "GotoHover.hs"
9732

@@ -110,9 +45,9 @@ tests = let
11045
, tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]
11146

11247
recordDotSyntaxTests =
113-
[ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"
114-
, tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"
115-
, tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
48+
[ tst (getHover, checkHoverM) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"
49+
, tst (getHover, checkHoverM) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"
50+
, tst (getHover, checkHoverM) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
11651
]
11752

11853
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
@@ -128,7 +63,7 @@ tests = let
12863
( runDef $ tst def look sourceFilePath expect title
12964
, runHover $ tst hover look sourceFilePath expect title ) where
13065
def = (getDefinitions, checkDefs)
131-
hover = (getHover , checkHover)
66+
hover = (getHover , checkHoverM)
13267

13368
-- search locations expectations on results
13469
-- TODO: Lookup of record field should return exactly one result

‎ghcide-test/exe/Hover.hs‎

Lines changed: 74 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,19 @@
1-
module Hover where
1+
module Hover (
2+
assertFoundIn,
3+
assertNotFoundIn,
4+
checkHover,
5+
checkHoverM,
6+
) where
27

38
import Config
9+
import Control.Arrow
10+
import Control.Lens
411
import Control.Monad
512
import Data.Foldable
6-
import qualified Data.Text as T
13+
import Data.Maybe (mapMaybe)
14+
import qualified Data.Text as T
715
import Development.IDE.Test
16+
import qualified Language.LSP.Protocol.Lens as L
817
import Test.Hls
918
import Text.Regex.TDFA
1019

@@ -21,20 +30,79 @@ assertNotFoundIn part whole =
2130
(not . T.isInfixOf part $ whole)
2231

2332
checkHover :: (HasCallStack) => Maybe Hover -> [Expect] -> Session ()
24-
checkHover hover expectations = traverse_ check expectations
33+
checkHover hover expectations = checkHoverM hover (pure expectations)
34+
35+
checkHoverM :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
36+
checkHoverM hover expectations =
37+
traverse_ check =<< expectations
2538
where
2639
check :: (HasCallStack) => Expect -> Session ()
2740
check expected =
2841
case hover of
2942
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
3043
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
31-
,_range = _rangeInHover } ->
44+
,_range = rangeInHover } ->
3245
case expected of
33-
ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet."
34-
ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet."
46+
ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
47+
ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
3548
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
3649
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
3750
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
3851
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
3952
_ -> pure () -- all other expectations not relevant to hover
4053
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
54+
55+
checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
56+
checkHoverRange expectedRange rangeInHover msg =
57+
let
58+
lineCol = extractLineColFromHoverMsg msg
59+
-- looks like hovers use 1-based numbering while definitions use 0-based
60+
-- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
61+
adjust Position{_line = l, _character = c} =
62+
Position{_line = l + 1, _character = c + 1}
63+
in
64+
case map (read . T.unpack) lineCol of
65+
[l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c
66+
_ -> liftIO $ assertFailure $
67+
"expected: " <> show ("[...]<FILE_NAME>:<LINE>:<COL>**[...]", Just expectedRange) <>
68+
"\n but got: " <> show (msg, rangeInHover)
69+
70+
-- | Extract the source position from a message such as
71+
--
72+
-- @
73+
-- "*Defined at C://file-name.hs:22:3*"
74+
-- @
75+
--
76+
-- >>> extractLineColFromHoverMsg "*Defined at C://tmp/GotoHover.hs:22:3*"
77+
-- ["22","3"]
78+
--
79+
-- >>> extractLineColFromHoverMsg "*Defined at /tmp/GotoHover.hs:22:3*"
80+
-- ["22","3"]
81+
extractLineColFromHoverMsg :: T.Text -> [T.Text]
82+
extractLineColFromHoverMsg =
83+
-- Windows: "*Defined at C://tmp/GotoHover.hs:22:3*"
84+
-- Linux: "*Defined at /tmp/GotoHover.hs:22:3*"
85+
T.lines
86+
-- Windows: ["*Defined at C://tmp/GotoHover.hs:22:3*"]
87+
-- Linux: ["*Defined at /tmp/GotoHover.hs:22:3*"]
88+
>>> mapMaybe (T.stripPrefix "*Defined at ")
89+
-- Windows: ["C://tmp/GotoHover.hs:22:3*"]
90+
-- Linux: ["/tmp/GotoHover.hs:22:3*"]
91+
>>> last
92+
-- Windows: "C://tmp/GotoHover.hs:22:3*"
93+
-- Linux: "/tmp/GotoHover.hs:22:3*"
94+
>>> T.dropEnd 1
95+
-- Windows: "C://tmp/GotoHover.hs:22:3"
96+
-- Linux: "/tmp/GotoHover.hs:22:3"
97+
>>> T.splitOn ":"
98+
-- Windows: ["C", "//tmp/GotoHover.hs", "22", "3"]
99+
-- Linux: ["/tmp/GotoHover.hs", "22", "3"]
100+
>>> reverse
101+
-- Windows: ["3", "22", "//tmp/GotoHover.hs", "C"]
102+
-- Linux: ["3", "22", "/tmp/GotoHover.hs"]
103+
>>> take 2
104+
-- Windows: ["3", "22"]
105+
-- Linux: ["3", "22"]
106+
>>> reverse
107+
-- Windows: ["22", "3"]
108+
-- Linux: ["22", "3"]

0 commit comments

Comments
 (0)