Skip to content

Commit 16fc8eb

Browse files
sgillespiesgillespie
committed
refactor: Make "broken" tests explicit
Create a type-level failure expectations, which allows us to add the expected failure behavior and the future ideal behavior
1 parent edfc677 commit 16fc8eb

File tree

7 files changed

+170
-73
lines changed

7 files changed

+170
-73
lines changed

‎ghcide/test/exe/FindDefinitionAndHoverTests.hs

Lines changed: 48 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -150,18 +150,18 @@ tests = let
150150
eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: Type -> Type -> Type\n"]]
151151
intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: Type\n"]]
152152
-- TODO: Kind signature of type variables should be `Type -> Type`
153-
tvrL40 = Position 44 37 ; kindV = [ExpectHoverText ["m"]]
153+
tvrL40 = Position 44 37 ; kindV = [ExpectHoverText ["m"]]; kindV' = [ExpectHoverText [":: * -> *\n"]]
154154
-- TODO: Hover of integer literal should be `7518`
155-
intL41 = Position 45 20 ; litI = [ExpectHoverText ["_ :: Int"]]
155+
intL41 = Position 45 20 ; litI = [ExpectHoverText ["_ :: Int"]]; litI' = [ExpectHoverText ["7518"]]
156156
-- TODO: Hover info of char literal should be `'f'`
157-
chrL36 = Position 41 24 ; litC = [ExpectHoverText ["_ :: Char"]]
157+
chrL36 = Position 41 24 ; litC = [ExpectHoverText ["_ :: Char"]]; litC' = [ExpectHoverText ["'f'"]]
158158
-- TODO: Hover info of Text literal should be `"dfgy"`
159-
txtL8 = Position 12 14 ; litT = [ExpectHoverText ["_ :: Text"]]
159+
txtL8 = Position 12 14 ; litT = [ExpectHoverText ["_ :: Text"]]; litT' = [ExpectHoverText ["\"dfgy\""]]
160160
-- TODO: Hover info of List literal should be `[8391 :: Int, 6268]`
161-
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[Int]"]]
161+
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[Int]"]]; litL' = [ExpectHoverText ["[8391 :: Int, 6268]"]]
162162
outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5]
163163
-- TODO: Hover info of local function signature should be `inner :: Bool`
164-
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner"], mkR 53 2 53 7]
164+
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner"], mkR 53 2 53 7]; innSig' = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
165165
holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
166166
holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]
167167
cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]
@@ -174,46 +174,46 @@ tests = let
174174
mkFindTests
175175
-- def hover look expect
176176
[ -- It suggests either going to the constructor or to the field
177-
test yes yes fffL4 fff "field in record definition"
178-
, test yes yes fffL8 fff' "field in record construction #1102"
179-
, test yes yes fffL14 fff' "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs
180-
, test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120
181-
, test yes yes dcL7 tcDC "data constructor record #1029"
182-
, test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121
183-
, test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147
184-
, test yes yes xtcL5 xtc "type constructor external #717,1028"
185-
, test yes yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120
186-
, test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120
187-
, test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120
188-
, test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120
189-
, test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120
190-
, test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120
191-
, test yes yes clL23 cls "class in instance declaration #1027"
192-
, test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147
193-
, test yes yes eclL15 ecls "external class in signature #717,1027"
194-
, test yes yes dnbL29 dnb "do-notation bind #1073"
195-
, test yes yes dnbL30 dnb "do-notation lookup"
196-
, test yes yes lcbL33 lcb "listcomp bind #1073"
197-
, test yes yes lclL33 lcb "listcomp lookup"
198-
, test yes yes mclL36 mcl "top-level fn 1st clause"
199-
, test yes yes mclL37 mcl "top-level fn 2nd clause #1030"
200-
, test yes yes spaceL37 space "top-level fn on space #1002"
201-
, test no yes docL41 doc "documentation #1129"
202-
, test no yes eitL40 kindE "kind of Either #1017"
203-
, test no yes intL40 kindI "kind of Int #1017"
204-
, test no yes tvrL40 kindV "kind of (* -> *) type variable #1017"
205-
, test no yes intL41 litI "literal Int in hover info #1016"
206-
, test no yes chrL36 litC "literal Char in hover info #1016"
207-
, test no yes txtL8 litT "literal Text in hover info #1016"
208-
, test no yes lstL43 litL "literal List in hover info #1016"
209-
, test yes yes cmtL68 lackOfdEq "no Core symbols #3280"
210-
, test no yes docL41 constr "type constraint in hover info #1012"
211-
, test no yes outL45 outSig "top-level signature #767"
212-
, test yes yes innL48 innSig "inner signature #767"
213-
, test no yes holeL60 hleInfo "hole without internal name #831"
214-
, test no yes holeL65 hleInfo2 "hole with variable"
215-
, test no yes cccL17 docLink "Haddock html links"
216-
, testM yes yes imported importedSig "Imported symbol"
177+
test (broken fff') yes fffL4 fff "field in record definition"
178+
, test yes yes fffL8 fff' "field in record construction #1102"
179+
, test yes yes fffL14 fff' "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs
180+
, test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120
181+
, test yes yes dcL7 tcDC "data constructor record #1029"
182+
, test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121
183+
, test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147
184+
, test yes yes xtcL5 xtc "type constructor external #717,1028"
185+
, test yes yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120
186+
, test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120
187+
, test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120
188+
, test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120
189+
, test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120
190+
, test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120
191+
, test yes yes clL23 cls "class in instance declaration #1027"
192+
, test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147
193+
, test yes yes eclL15 ecls "external class in signature #717,1027"
194+
, test yes yes dnbL29 dnb "do-notation bind #1073"
195+
, test yes yes dnbL30 dnb "do-notation lookup"
196+
, test yes yes lcbL33 lcb "listcomp bind #1073"
197+
, test yes yes lclL33 lcb "listcomp lookup"
198+
, test yes yes mclL36 mcl "top-level fn 1st clause"
199+
, test yes yes mclL37 mcl "top-level fn 2nd clause #1030"
200+
, test yes yes spaceL37 space "top-level fn on space #1002"
201+
, test no yes docL41 doc "documentation #1129"
202+
, test no yes eitL40 kindE "kind of Either #1017"
203+
, test no yes intL40 kindI "kind of Int #1017"
204+
, test no (broken kindV') tvrL40 kindV "kind of (* -> *) type variable #1017"
205+
, test no (broken litI') intL41 litI "literal Int in hover info #1016"
206+
, test no (broken litC') chrL36 litC "literal Char in hover info #1016"
207+
, test no (broken litT') txtL8 litT "literal Text in hover info #1016"
208+
, test no (broken litL') lstL43 litL "literal List in hover info #1016"
209+
, test yes yes cmtL68 lackOfdEq "no Core symbols #3280"
210+
, test no yes docL41 constr "type constraint in hover info #1012"
211+
, test no yes outL45 outSig "top-level signature #767"
212+
, test yes (broken innSig') innL48 innSig "inner signature #767"
213+
, test no yes holeL60 hleInfo "hole without internal name #831"
214+
, test no yes holeL65 hleInfo2 "hole with variable"
215+
, test no yes cccL17 docLink "Haddock html links"
216+
, testM yes yes imported importedSig "Imported symbol"
217217
, if isWindows then
218218
-- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997
219219
testM no yes reexported reexportedSig "Imported symbol (reexported)"
@@ -226,6 +226,8 @@ tests = let
226226
yes = Just -- test should run and pass
227227
no = const Nothing -- don't run this test at all
228228
--skip = const Nothing -- unreliable, don't run
229+
broken :: [Expect] -> TestTree -> Maybe TestTree
230+
broken _ = yes
229231

230232
checkFileCompiles :: FilePath -> Session () -> TestTree
231233
checkFileCompiles fp diag =

‎ghcide/test/exe/ReferenceTests.hs

Lines changed: 33 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE GADTs #-}
23
{-# LANGUAGE OverloadedStrings #-}
34

@@ -30,10 +31,13 @@ import Ide.PluginUtils (toAbsolute)
3031
import Ide.Types
3132
import System.FilePath (addTrailingPathSeparator,
3233
(</>))
33-
import Test.Hls (FromServerMessage' (..),
34+
import Test.Hls (BrokenBehavior (..),
35+
ExpectBroken (..),
36+
FromServerMessage' (..),
3437
SMethod (..),
3538
TCustomMessage (..),
36-
TNotificationMessage (..))
39+
TNotificationMessage (..),
40+
unCurrent)
3741
import Test.Hls.FileSystem (copyDir)
3842
import Test.Tasty
3943
import Test.Tasty.HUnit
@@ -90,15 +94,24 @@ tests = testGroup "references"
9094
]
9195

9296
-- TODO: references provider does not respect includeDeclaration parameter
93-
, referenceTest "INCORRECTLY returns declarations when we ask to exclude them"
97+
, referenceTestExpectFail "works when we ask to exclude declarations"
9498
("References.hs", 4, 7)
9599
NoExcludeDeclaration
96-
[ ("References.hs", 4, 6)
97-
, ("References.hs", 6, 0)
98-
, ("References.hs", 6, 14)
99-
, ("References.hs", 9, 7)
100-
, ("References.hs", 10, 11)
101-
]
100+
(BrokenIdeal
101+
[ ("References.hs", 6, 0)
102+
, ("References.hs", 6, 14)
103+
, ("References.hs", 9, 7)
104+
, ("References.hs", 10, 11)
105+
]
106+
)
107+
(BrokenCurrent
108+
[ ("References.hs", 4, 6)
109+
, ("References.hs", 6, 0)
110+
, ("References.hs", 6, 14)
111+
, ("References.hs", 9, 7)
112+
, ("References.hs", 10, 11)
113+
]
114+
)
102115
]
103116

104117
, testGroup "can get references to non FOIs"
@@ -194,6 +207,17 @@ referenceTest name loc includeDeclaration expected =
194207
where
195208
docs = map fst3 expected
196209

210+
referenceTestExpectFail
211+
:: (HasCallStack)
212+
=> String
213+
-> SymbolLocation
214+
-> IncludeDeclaration
215+
-> ExpectBroken 'Ideal [SymbolLocation]
216+
-> ExpectBroken 'Current [SymbolLocation]
217+
-> TestTree
218+
referenceTestExpectFail name loc includeDeclaration _ =
219+
referenceTest name loc includeDeclaration . unCurrent
220+
197221
type SymbolLocation = (FilePath, UInt, UInt)
198222

199223
expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion

‎hls-test-utils/src/Test/Hls.hs

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,10 @@ module Test.Hls
3939
-- * Helpful re-exports
4040
PluginDescriptor,
4141
IdeState,
42+
-- * Helpers for expected test case failuers
43+
BrokenBehavior(..),
44+
ExpectBroken(..),
45+
unCurrent,
4246
-- * Assertion helper functions
4347
waitForProgressDone,
4448
waitForAllProgressDone,
@@ -166,6 +170,15 @@ instance Pretty LogTestHarness where
166170
LogCleanup -> "Cleaned up temporary directory"
167171
LogNoCleanup -> "No cleanup of temporary directory"
168172

173+
data BrokenBehavior = Current | Ideal
174+
175+
data ExpectBroken (k :: BrokenBehavior) a where
176+
BrokenCurrent :: a -> ExpectBroken 'Current a
177+
BrokenIdeal :: a -> ExpectBroken 'Ideal a
178+
179+
unCurrent :: ExpectBroken 'Current a -> a
180+
unCurrent (BrokenCurrent a) = a
181+
169182
-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
170183
defaultTestRunner :: TestTree -> IO ()
171184
defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000)
@@ -903,4 +916,3 @@ kick proxyMsg = do
903916
case fromJSON _params of
904917
Success x -> return x
905918
other -> error $ "Failed to parse kick/done details: " <> show other
906-

‎plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE OverloadedStrings #-}
34
{-# LANGUAGE TypeFamilies #-}

‎plugins/hls-explicit-fixity-plugin/test/Main.hs

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE OverloadedStrings #-}
23

34
module Main where
@@ -41,15 +42,29 @@ tests = testGroup "Explicit fixity"
4142
, hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`"
4243
, hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`"
4344
-- TODO: Ensure that there is no one extra new line in import statement
44-
, hoverTest "import" (Position 2 18) "Control.Monad\n\n"
45+
, hoverTestExpectFail
46+
"import"
47+
(Position 2 18)
48+
(BrokenIdeal "Control.Monad***")
49+
(BrokenCurrent "Control.Monad\n\n")
4550
, hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"
4651
]
4752

4853
hoverTest :: TestName -> Position -> T.Text -> TestTree
4954
hoverTest = hoverTest' "Hover.hs"
55+
5056
hoverTestImport :: TestName -> Position -> T.Text -> TestTree
5157
hoverTestImport = hoverTest' "HoverImport.hs"
5258

59+
hoverTestExpectFail
60+
:: TestName
61+
-> Position
62+
-> ExpectBroken 'Ideal T.Text
63+
-> ExpectBroken 'Current T.Text
64+
-> TestTree
65+
hoverTestExpectFail title pos _ =
66+
hoverTest title pos . unCurrent
67+
5368
hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree
5469
hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do
5570
doc <- openDoc docName "haskell"

0 commit comments

Comments
 (0)