Avoid expectFail in the test suite

ghcide/test/exe/Config.hs

@@ -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
@@ -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
@@ -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
@@ -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

ghcide/test/exe/FindDefinitionAndHoverTests.hs

@@ -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]
@@ -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"]
@@ -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)"
@@ -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 =

ghcide/test/exe/ReferenceTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -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
 
 
@@ -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"
@@ -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

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

@@ -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,
@@ -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)
@@ -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
-

plugins/hls-cabal-fmt-plugin/test/Main.hs

@@ -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