Skip to content

Commit e64e4b1

Browse files
crtschincrtschin
committed
Add tests for hovering constructors
1 parent 938cdcd commit e64e4b1

9 files changed

Lines changed: 104 additions & 21 deletions

‎ghcide-test/data/hover/Constructors.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
module Constructors where
2+
3+
data A = A
4+
data B = B Int Word Bool
5+
data C = C ![Int] {-# UNPACK #-} !Bool
6+
data D = D { da :: Int, db :: Bool }
7+
data E = E { ea :: !Int, eb :: {-# UNPACK #-} ![Bool] }
8+
newtype F = F Int

‎ghcide-test/data/hover/ConstructorsLinear.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
{-# LANGUAGE LinearTypes #-}
2+
module ConstructorsLinear where
3+
4+
data A = A
5+
data B = B Int Word Bool
6+
data C = C ![Int] {-# UNPACK #-} !Bool
7+
data D = D { da :: Int, db :: Bool }
8+
data E = E { ea :: !Int, eb :: {-# UNPACK #-} ![Bool] }
9+
newtype F = F Int

‎ghcide-test/data/hover/hie.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}}
1+
cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation", "Constructors", "ConstructorsLinear"]}}

‎ghcide-test/exe/ConstructorHoverTests.hs‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
3+
module ConstructorHoverTests (tests) where
4+
5+
import Config
6+
import Hover
7+
import Test.Hls
8+
import Test.Hls.FileSystem (copyDir)
9+
10+
tests :: TestTree
11+
tests =
12+
testGroup
13+
"constructor hover (#2904)"
14+
[ testGroup
15+
"Constructors.hs"
16+
[ test "A" "Constructors.hs" (Position 2 9) [ExpectHoverText ["A :: A"]]
17+
, test "B" "Constructors.hs" (Position 3 9) [ExpectHoverText ["B :: Int -> Word -> Bool -> B"], ExpectHoverExcludeText ["%1 ->"]]
18+
, test "C" "Constructors.hs" (Position 4 9) [ExpectHoverText ["C :: [Int] -> Bool -> C"], ExpectHoverExcludeText ["%1 ->"]]
19+
, test "D" "Constructors.hs" (Position 5 9) [ExpectHoverText ["D :: Int -> Bool -> D"], ExpectHoverExcludeText ["%1 ->"]]
20+
, test "E" "Constructors.hs" (Position 6 9) [ExpectHoverText ["E :: Int -> [Bool] -> E"], ExpectHoverExcludeText ["%1 ->"]]
21+
, test "F" "Constructors.hs" (Position 7 12) [ExpectHoverText ["F :: Int -> F"], ExpectHoverExcludeText ["%1 ->"]]
22+
]
23+
, testGroup
24+
"ConstructorsLinear.hs"
25+
[ test "A" "ConstructorsLinear.hs" (Position 3 9) [ExpectHoverText ["A :: A"]]
26+
, test "B" "ConstructorsLinear.hs" (Position 4 9) [ExpectHoverText ["B :: Int %1 -> Word %1 -> Bool %1 -> B"]]
27+
, test "C" "ConstructorsLinear.hs" (Position 5 9) [ExpectHoverText ["C :: [Int] %1 -> Bool %1 -> C"]]
28+
, test "D" "ConstructorsLinear.hs" (Position 6 9) [ExpectHoverText ["D :: Int %1 -> Bool %1 -> D"]]
29+
, test "E" "ConstructorsLinear.hs" (Position 7 9) [ExpectHoverText ["E :: Int %1 -> [Bool] %1 -> E"]]
30+
, test "F" "ConstructorsLinear.hs" (Position 8 12) [ExpectHoverText ["F :: Int %1 -> F"]]
31+
]
32+
]
33+
34+
test :: String -> FilePath -> Position -> [Expect] -> TestTree
35+
test title fileName pos expectations =
36+
testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
37+
doc <- openDoc fileName "haskell"
38+
waitForProgressDone
39+
hover <- getHover doc pos
40+
checkHover hover expectations

‎ghcide-test/exe/FindDefinitionAndHoverTests.hs‎

Lines changed: 1 addition & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import Control.Category ((>>>))
1717
import Control.Lens ((^.))
1818
import Development.IDE.Test (expectDiagnostics,
1919
standardizeQuotes)
20+
import Hover
2021
import Test.Hls
2122
import Test.Hls.FileSystem (copyDir)
2223
import Text.Regex.TDFA ((=~))
@@ -91,16 +92,6 @@ tests = let
9192
"expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
9293
"\n but got: " <> show (msg, rangeInHover)
9394

94-
assertFoundIn :: T.Text -> T.Text -> Assertion
95-
assertFoundIn part whole = assertBool
96-
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
97-
(part `T.isInfixOf` whole)
98-
99-
assertNotFoundIn :: T.Text -> T.Text -> Assertion
100-
assertNotFoundIn part whole = assertBool
101-
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
102-
(not . T.isInfixOf part $ whole)
103-
10495
sourceFilePath = T.unpack sourceFileName
10596
sourceFileName = "GotoHover.hs"
10697

‎ghcide-test/exe/FindImplementationAndHoverTests.hs‎

Lines changed: 1 addition & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Text.Regex.TDFA ((=~))
1414

1515
import Config
1616
import Development.IDE.Test (standardizeQuotes)
17+
import Hover
1718
import Test.Hls
1819
import Test.Hls.FileSystem (copyDir)
1920

@@ -47,16 +48,6 @@ tests = let
4748
_ -> pure () -- all other expectations not relevant to hover
4849
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
4950

50-
assertFoundIn :: T.Text -> T.Text -> Assertion
51-
assertFoundIn part whole = assertBool
52-
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
53-
(part `T.isInfixOf` whole)
54-
55-
assertNotFoundIn :: T.Text -> T.Text -> Assertion
56-
assertNotFoundIn part whole = assertBool
57-
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
58-
(not . T.isInfixOf part $ whole)
59-
6051
sourceFilePath = T.unpack sourceFileName
6152
sourceFileName = "GotoImplementation.hs"
6253

‎ghcide-test/exe/Hover.hs‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
module Hover where
2+
3+
import Config
4+
import Control.Monad
5+
import Data.Foldable
6+
import qualified Data.Text as T
7+
import Development.IDE.Test
8+
import Test.Hls
9+
import Text.Regex.TDFA
10+
11+
assertFoundIn :: T.Text -> T.Text -> Assertion
12+
assertFoundIn part whole =
13+
assertBool
14+
(T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
15+
(part `T.isInfixOf` whole)
16+
17+
assertNotFoundIn :: T.Text -> T.Text -> Assertion
18+
assertNotFoundIn part whole =
19+
assertBool
20+
(T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
21+
(not . T.isInfixOf part $ whole)
22+
23+
checkHover :: (HasCallStack) => Maybe Hover -> [Expect] -> Session ()
24+
checkHover hover expectations = traverse_ check expectations
25+
where
26+
check :: (HasCallStack) => Expect -> Session ()
27+
check expected =
28+
case hover of
29+
Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
30+
Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
31+
,_range = _rangeInHover } ->
32+
case expected of
33+
ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet."
34+
ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet."
35+
ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
36+
ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
37+
ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
38+
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
39+
_ -> pure () -- all other expectations not relevant to hover
40+
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

‎ghcide-test/exe/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ import BootTests
3939
import ClientSettingsTests
4040
import CodeLensTests
4141
import CompletionTests
42+
import ConstructorHoverTests
4243
import CPPTests
4344
import CradleTests
4445
import DependentFileTest
@@ -79,6 +80,7 @@ main = do
7980
, CodeLensTests.tests
8081
, OutlineTests.tests
8182
, HighlightTests.tests
83+
, ConstructorHoverTests.tests
8284
, FindDefinitionAndHoverTests.tests
8385
, FindImplementationAndHoverTests.tests
8486
, PluginSimpleTests.tests

‎haskell-language-server.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2139,6 +2139,7 @@ test-suite ghcide-tests
21392139
ClientSettingsTests
21402140
CodeLensTests
21412141
CompletionTests
2142+
ConstructorHoverTests
21422143
CPPTests
21432144
CradleTests
21442145
DependentFileTest
@@ -2151,6 +2152,7 @@ test-suite ghcide-tests
21512152
HaddockTests
21522153
HieDbRetry
21532154
HighlightTests
2155+
Hover
21542156
IfaceTests
21552157
InitializeResponseTests
21562158
LogType

0 commit comments

Comments
 (0)