Skip to content

Commit

Permalink
refactor: Make "broken" tests explicit
Browse files Browse the repository at this point in the history 
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 committed Sep 27, 2024
1 parent edfc677 commit 16fc8eb
Show file tree
Hide file tree
Showing 7 changed files with 170 additions and 73 deletions.
94 changes: 48 additions & 46 deletions ghcide/test/exe/FindDefinitionAndHoverTests.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -150,18 +150,18 @@ tests = let
eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: Type -> Type -> Type\n"]]
intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: Type\n"]]
-- TODO: Kind signature of type variables should be `Type -> Type`
tvrL40 = Position 44 37 ; kindV = [ExpectHoverText ["m"]]
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"]]
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"]]
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"]]
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]"]]
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]
-- TODO: Hover info of local function signature should be `inner :: Bool`
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner"], mkR 53 2 53 7]
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 @@ -174,46 +174,46 @@ tests = let
mkFindTests
-- def hover look expect
[ -- It suggests either going to the constructor or to the field
test yes 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 yes tvrL40 kindV "kind of (* -> *) type variable #1017"
, test no yes intL41 litI "literal Int in hover info #1016"
, test no yes chrL36 litC "literal Char in hover info #1016"
, test no yes txtL8 litT "literal Text in hover info #1016"
, test no yes 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 yes 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 @@ -226,6 +226,8 @@ tests = let
yes = Just -- test should run and pass
no = const Nothing -- don't run this test at all
--skip = const Nothing -- unreliable, don't run
broken :: [Expect] -> TestTree -> Maybe TestTree
broken _ = yes

checkFileCompiles :: FilePath -> Session () -> TestTree
checkFileCompiles fp diag =
Expand Down
42 changes: 33 additions & 9 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,10 +31,13 @@ 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.HUnit
Expand Down Expand Up @@ -90,15 +94,24 @@ tests = testGroup "references"
]

-- TODO: references provider does not respect includeDeclaration parameter
, referenceTest "INCORRECTLY returns declarations when we ask to exclude them"
, referenceTestExpectFail "works when we ask to exclude declarations"
("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 @@ -194,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

1 change: 1 addition & 0 deletions plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down
17 changes: 16 additions & 1 deletion plugins/hls-explicit-fixity-plugin/test/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where
Expand Down Expand Up @@ -41,15 +42,29 @@ tests = testGroup "Explicit fixity"
, hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`"
, hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`"
-- TODO: Ensure that there is no one extra new line in import statement
, hoverTest "import" (Position 2 18) "Control.Monad\n\n"
, hoverTestExpectFail
"import"
(Position 2 18)
(BrokenIdeal "Control.Monad***")
(BrokenCurrent "Control.Monad\n\n")
, hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"
]

hoverTest :: TestName -> Position -> T.Text -> TestTree
hoverTest = hoverTest' "Hover.hs"

hoverTestImport :: TestName -> Position -> T.Text -> TestTree
hoverTestImport = hoverTest' "HoverImport.hs"

hoverTestExpectFail
:: TestName
-> Position
-> ExpectBroken 'Ideal T.Text
-> ExpectBroken 'Current T.Text
-> TestTree
hoverTestExpectFail title pos _ =
hoverTest title pos . unCurrent

hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree
hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do
doc <- openDoc docName "haskell"
Expand Down
Loading

0 comments on commit 16fc8eb

Please sign in to comment.