Skip to content

Commit

Permalink
Avoid expectFail in the test suite (#4402)
Browse files Browse the repository at this point in the history 
* Replace `expectFail` references with explicit checks

* 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
  • Loading branch information
@sgillespie
sgillespie authored Sep 29, 2024
1 parent 7385915 commit 838c77c
Show file tree
Hide file tree
Showing 22 changed files with 316 additions and 201 deletions.
8 changes: 8 additions & 0 deletions ghcide/test/exe/Config.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ module Config(

import Control.Exception (bracket_)
import Control.Lens.Setter ((.~))
import Control.Monad (unless)
import Data.Foldable (traverse_)
import Data.Function ((&))
import qualified Data.Text as T
Expand Down Expand Up @@ -100,6 +101,7 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

data Expect
= ExpectRange Range -- Both gotoDef and hover should report this range
| ExpectRanges [Range] -- definition lookup with multiple results
| ExpectLocation Location
-- | ExpectDefRange Range -- Only gotoDef should report this range
| ExpectHoverRange Range -- Only hover should report this range
Expand All @@ -124,6 +126,8 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta
check (ExpectRange expectedRange) = do
def <- assertOneDefinitionFound defs
assertRangeCorrect def expectedRange
check (ExpectRanges ranges) =
traverse_ (assertHasRange defs) ranges
check (ExpectLocation expectedLocation) = do
def <- assertOneDefinitionFound defs
liftIO $ do
Expand All @@ -142,6 +146,10 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta
assertRangeCorrect Location{_range = foundRange} expectedRange =
liftIO $ expectedRange @=? foundRange

assertHasRange actualRanges expectedRange = do
let hasRange = any (\Location{_range=foundRange} -> foundRange == expectedRange) actualRanges
unless hasRange $ liftIO $ assertFailure $
"expected range: " <> show expectedRange <> "\nbut got ranges: " <> show defs

canonicalizeLocation :: Location -> IO Location
canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
Expand Down
113 changes: 59 additions & 54 deletions ghcide/test/exe/FindDefinitionAndHoverTests.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -119,8 +119,9 @@ tests = let
hover = (getHover , checkHover)

-- search locations expectations on results
fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
fffL8 = Position 12 4 ;
-- TODO: Lookup of record field should return exactly one result
fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7; fff = [ExpectRanges [fffR, mkRange 7 23 9 16]]
fffL8 = Position 12 4 ; fff' = [ExpectRange fffR]
fffL14 = Position 18 7 ;
aL20 = Position 19 15
aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
Expand Down Expand Up @@ -148,13 +149,19 @@ tests = let
; constr = [ExpectHoverText ["Monad m"]]
eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: Type -> Type -> Type\n"]]
intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: Type\n"]]
tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
-- TODO: Kind signature of type variables should be `Type -> Type`
tvrL40 = Position 44 37 ; kindV = [ExpectHoverText ["m"]]; kindV' = [ExpectHoverText [":: * -> *\n"]]
-- TODO: Hover of integer literal should be `7518`
intL41 = Position 45 20 ; litI = [ExpectHoverText ["_ :: Int"]]; litI' = [ExpectHoverText ["7518"]]
-- TODO: Hover info of char literal should be `'f'`
chrL36 = Position 41 24 ; litC = [ExpectHoverText ["_ :: Char"]]; litC' = [ExpectHoverText ["'f'"]]
-- TODO: Hover info of Text literal should be `"dfgy"`
txtL8 = Position 12 14 ; litT = [ExpectHoverText ["_ :: Text"]]; litT' = [ExpectHoverText ["\"dfgy\""]]
-- TODO: Hover info of List literal should be `[8391 :: Int, 6268]`
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[Int]"]]; litL' = [ExpectHoverText ["[8391 :: Int, 6268]"]]
outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5]
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
-- TODO: Hover info of local function signature should be `inner :: Bool`
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner"], mkR 53 2 53 7]; innSig' = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]
cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]
Expand All @@ -167,46 +174,46 @@ tests = let
mkFindTests
-- def hover look expect
[ -- It suggests either going to the constructor or to the field
test broken yes fffL4 fff "field in record definition"
, test yes yes fffL8 fff "field in record construction #1102"
, test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs
, test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120
, test yes yes dcL7 tcDC "data constructor record #1029"
, test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121
, test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147
, test yes yes xtcL5 xtc "type constructor external #717,1028"
, test yes yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120
, test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120
, test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120
, test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120
, test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120
, test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120
, test yes yes clL23 cls "class in instance declaration #1027"
, test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147
, test yes yes eclL15 ecls "external class in signature #717,1027"
, test yes yes dnbL29 dnb "do-notation bind #1073"
, test yes yes dnbL30 dnb "do-notation lookup"
, test yes yes lcbL33 lcb "listcomp bind #1073"
, test yes yes lclL33 lcb "listcomp lookup"
, test yes yes mclL36 mcl "top-level fn 1st clause"
, test yes yes mclL37 mcl "top-level fn 2nd clause #1030"
, test yes yes spaceL37 space "top-level fn on space #1002"
, test no yes docL41 doc "documentation #1129"
, test no yes eitL40 kindE "kind of Either #1017"
, test no yes intL40 kindI "kind of Int #1017"
, test no broken tvrL40 kindV "kind of (* -> *) type variable #1017"
, test no broken intL41 litI "literal Int in hover info #1016"
, test no broken chrL36 litC "literal Char in hover info #1016"
, test no broken txtL8 litT "literal Text in hover info #1016"
, test no broken lstL43 litL "literal List in hover info #1016"
, test yes yes cmtL68 lackOfdEq "no Core symbols #3280"
, test no yes docL41 constr "type constraint in hover info #1012"
, test no yes outL45 outSig "top-level signature #767"
, test broken broken innL48 innSig "inner signature #767"
, test no yes holeL60 hleInfo "hole without internal name #831"
, test no yes holeL65 hleInfo2 "hole with variable"
, test no yes cccL17 docLink "Haddock html links"
, testM yes yes imported importedSig "Imported symbol"
test (broken fff') yes fffL4 fff "field in record definition"
, test yes yes fffL8 fff' "field in record construction #1102"
, test yes yes fffL14 fff' "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs
, test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120
, test yes yes dcL7 tcDC "data constructor record #1029"
, test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121
, test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147
, test yes yes xtcL5 xtc "type constructor external #717,1028"
, test yes yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120
, test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120
, test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120
, test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120
, test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120
, test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120
, test yes yes clL23 cls "class in instance declaration #1027"
, test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147
, test yes yes eclL15 ecls "external class in signature #717,1027"
, test yes yes dnbL29 dnb "do-notation bind #1073"
, test yes yes dnbL30 dnb "do-notation lookup"
, test yes yes lcbL33 lcb "listcomp bind #1073"
, test yes yes lclL33 lcb "listcomp lookup"
, test yes yes mclL36 mcl "top-level fn 1st clause"
, test yes yes mclL37 mcl "top-level fn 2nd clause #1030"
, test yes yes spaceL37 space "top-level fn on space #1002"
, test no yes docL41 doc "documentation #1129"
, test no yes eitL40 kindE "kind of Either #1017"
, test no yes intL40 kindI "kind of Int #1017"
, test no (broken kindV') tvrL40 kindV "kind of (* -> *) type variable #1017"
, test no (broken litI') intL41 litI "literal Int in hover info #1016"
, test no (broken litC') chrL36 litC "literal Char in hover info #1016"
, test no (broken litT') txtL8 litT "literal Text in hover info #1016"
, test no (broken litL') lstL43 litL "literal List in hover info #1016"
, test yes yes cmtL68 lackOfdEq "no Core symbols #3280"
, test no yes docL41 constr "type constraint in hover info #1012"
, test no yes outL45 outSig "top-level signature #767"
, test yes (broken innSig') innL48 innSig "inner signature #767"
, test no yes holeL60 hleInfo "hole without internal name #831"
, test no yes holeL65 hleInfo2 "hole with variable"
, test no yes cccL17 docLink "Haddock html links"
, testM yes yes imported importedSig "Imported symbol"
, if isWindows then
-- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997
testM no yes reexported reexportedSig "Imported symbol (reexported)"
Expand All @@ -215,14 +222,12 @@ tests = let
, test no yes thLocL57 thLoc "TH Splice Hover"
, test yes yes import310 pkgTxt "show package name and its version"
]
where yes, broken :: (TestTree -> Maybe TestTree)
yes = Just -- test should run and pass
broken = Just . (`xfail` "known broken")
where yes :: (TestTree -> Maybe TestTree)
yes = Just -- test should run and pass
no = const Nothing -- don't run this test at all
--skip = const Nothing -- unreliable, don't run

xfail :: TestTree -> String -> TestTree
xfail = flip expectFailBecause
broken :: [Expect] -> TestTree -> Maybe TestTree
broken _ = yes

checkFileCompiles :: FilePath -> Session () -> TestTree
checkFileCompiles fp diag =
Expand Down
54 changes: 34 additions & 20 deletions ghcide/test/exe/ReferenceTests.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

Expand Down Expand Up @@ -30,13 +31,15 @@ import Ide.PluginUtils (toAbsolute)
import Ide.Types
import System.FilePath (addTrailingPathSeparator,
(</>))
import Test.Hls (FromServerMessage' (..),
import Test.Hls (BrokenBehavior (..),
ExpectBroken (..),
FromServerMessage' (..),
SMethod (..),
TCustomMessage (..),
TNotificationMessage (..))
TNotificationMessage (..),
unCurrent)
import Test.Hls.FileSystem (copyDir)
import Test.Tasty
import Test.Tasty.ExpectedFailure
import Test.Tasty.HUnit


Expand Down Expand Up @@ -90,25 +93,25 @@ tests = testGroup "references"
, ("Main.hs", 10, 0)
]

, expectFailBecause "references provider does not respect includeDeclaration parameter" $
referenceTest "works when we ask to exclude declarations"
-- TODO: references provider does not respect includeDeclaration parameter
, referenceTestExpectFail "works when we ask to exclude declarations"
("References.hs", 4, 7)
NoExcludeDeclaration
[ ("References.hs", 6, 0)
, ("References.hs", 6, 14)
, ("References.hs", 9, 7)
, ("References.hs", 10, 11)
]

, referenceTest "INCORRECTLY returns declarations when we ask to exclude them"
("References.hs", 4, 7)
NoExcludeDeclaration
[ ("References.hs", 4, 6)
, ("References.hs", 6, 0)
, ("References.hs", 6, 14)
, ("References.hs", 9, 7)
, ("References.hs", 10, 11)
]
(BrokenIdeal
[ ("References.hs", 6, 0)
, ("References.hs", 6, 14)
, ("References.hs", 9, 7)
, ("References.hs", 10, 11)
]
)
(BrokenCurrent
[ ("References.hs", 4, 6)
, ("References.hs", 6, 0)
, ("References.hs", 6, 14)
, ("References.hs", 9, 7)
, ("References.hs", 10, 11)
]
)
]

, testGroup "can get references to non FOIs"
Expand Down Expand Up @@ -204,6 +207,17 @@ referenceTest name loc includeDeclaration expected =
where
docs = map fst3 expected

referenceTestExpectFail
:: (HasCallStack)
=> String
-> SymbolLocation
-> IncludeDeclaration
-> ExpectBroken 'Ideal [SymbolLocation]
-> ExpectBroken 'Current [SymbolLocation]
-> TestTree
referenceTestExpectFail name loc includeDeclaration _ =
referenceTest name loc includeDeclaration . unCurrent

type SymbolLocation = (FilePath, UInt, UInt)

expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion
Expand Down
14 changes: 13 additions & 1 deletion hls-test-utils/src/Test/Hls.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,10 @@ module Test.Hls
-- * Helpful re-exports
PluginDescriptor,
IdeState,
-- * Helpers for expected test case failuers
BrokenBehavior(..),
ExpectBroken(..),
unCurrent,
-- * Assertion helper functions
waitForProgressDone,
waitForAllProgressDone,
Expand Down Expand Up @@ -166,6 +170,15 @@ instance Pretty LogTestHarness where
LogCleanup -> "Cleaned up temporary directory"
LogNoCleanup -> "No cleanup of temporary directory"

data BrokenBehavior = Current | Ideal

data ExpectBroken (k :: BrokenBehavior) a where
BrokenCurrent :: a -> ExpectBroken 'Current a
BrokenIdeal :: a -> ExpectBroken 'Ideal a

unCurrent :: ExpectBroken 'Current a -> a
unCurrent (BrokenCurrent a) = a

-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000)
Expand Down Expand Up @@ -903,4 +916,3 @@ kick proxyMsg = do
case fromJSON _params of
Success x -> return x
other -> error $ "Failed to parse kick/done details: " <> show other

5 changes: 3 additions & 2 deletions plugins/hls-cabal-fmt-plugin/test/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -54,8 +54,9 @@ tests found = testGroup "cabal-fmt"
cabalFmtGolden found "formats a simple document" "simple_testdata" "formatted_document" $ \doc -> do
formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing)

, expectFailBecause "cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking issue: https://github.com/phadej/cabal-fmt/pull/82" $
cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do
-- TODO: cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking
-- issue: https://github.com/phadej/cabal-fmt/pull/82
, cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do
formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing)

, cabalFmtGolden found "formats a document with lib information" "lib_testdata" "formatted_document" $ \doc -> do
Expand Down
Loading

0 comments on commit 838c77c

Please sign in to comment.