Skip to content

Commit 326b1a4

Browse files
fendorfendor
committed
Generalize hover test assertions
1 parent a238c1c commit 326b1a4

3 files changed

Lines changed: 84 additions & 82 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: 9 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,20 @@
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
21-
import Ide.Types (Config (..), OptLinkTo (..))
15+
import Ide.Types
2216
import Test.Hls
2317
import Test.Hls.FileSystem (copyDir)
24-
import Text.Regex.TDFA ((=~))
2518

2619
tests :: TestTree
2720
tests = let
@@ -35,64 +28,6 @@ tests = let
3528
check found targetRange
3629

3730

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

@@ -113,9 +48,9 @@ tests = let
11348
, tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]
11449

11550
recordDotSyntaxTests =
116-
[ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"
117-
, tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"
118-
, tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
51+
[ tst (getHover, checkHoverM) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"
52+
, tst (getHover, checkHoverM) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"
53+
, tst (getHover, checkHoverM) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
11954
]
12055

12156
test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
@@ -131,7 +66,7 @@ tests = let
13166
( runDef $ tst def look sourceFilePath expect title
13267
, runHover $ tst hover look sourceFilePath expect title ) where
13368
def = (getDefinitions, checkDefs)
134-
hover = (getHover , checkHover)
69+
hover = (getHover , checkHoverM)
13570

13671
-- search locations expectations on results
13772
-- 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)