Replace expectFail references with explicit checks

Author: sgillespie

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"]]
+  -- TODO: Hover of integer literal should be `7518`
+  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["_ :: Int"]]
+  -- TODO: Hover info of char literal should be `'f'`
+  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["_ :: Char"]]
+  -- TODO: Hover info of Text literal should be `"dfgy"`
+  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["_ :: Text"]]
+  -- TODO: Hover info of List literal should be `[8391 :: Int, 6268]`
+  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[Int]"]]
   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]
   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,9 +174,9 @@ 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    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
@@ -194,15 +201,15 @@ tests = let
   , 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  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  broken broken innL48     innSig        "inner     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"
@@ -215,15 +222,11 @@ 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
-
 checkFileCompiles :: FilePath -> Session () -> TestTree
 checkFileCompiles fp diag =
    testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do

ghcide/test/exe/ReferenceTests.hs

@@ -36,7 +36,6 @@ import           Test.Hls                        (FromServerMessage' (..),
                                                   TNotificationMessage (..))
 import           Test.Hls.FileSystem             (copyDir)
 import           Test.Tasty
-import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.HUnit
 
 
@@ -90,16 +89,7 @@ tests = testGroup "references"
                           , ("Main.hs", 10, 0)
                           ]
 
-          , expectFailBecause "references provider does not respect includeDeclaration parameter" $
- referenceTest "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)
-                          ]
-
+          -- TODO: references provider does not respect includeDeclaration parameter
           , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"
                           ("References.hs", 4, 7)
                           NoExcludeDeclaration

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

@@ -39,8 +39,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

plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal

@@ -6,10 +6,7 @@ extra-source-files: CHANGELOG.md
 
 library
   -- cabal-fmt: expand src
-  exposed-modules:
-    MyLib
-    MyOtherLib
-
+  exposed-modules:  MyLib
   build-depends:    base ^>=4.14.1.0
   hs-source-dirs:   src
   default-language: Haskell2010

plugins/hls-cabal-plugin/test/CabalAdd.hs

@@ -17,7 +17,6 @@ import           System.FilePath
 import           Test.Hls                    (Session, TestTree, _R, anyMessage,
                                               assertEqual, documentContents,
                                               executeCodeAction,
-                                              expectFailBecause,
                                               getAllCodeActions,
                                               getDocumentEdit, liftIO, openDoc,
                                               skipManyTill, testCase, testGroup,
@@ -100,10 +99,9 @@ cabalAddTests =
                                    , ("AAI", "0.1")
                                    , ("AWin32Console", "1.19.1")
                                    ]
-    , expectFailBecause "TODO fix regex for these cases" $
-      testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma"
-                                   [ "It is a member of the hidden package \82163d-graphics-examples\8217"
-                                   , "It is a member of the hidden package \82163d-graphics-examples-1.1.6\8217"
+    , testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma"
+                                   [ "It is a member of the hidden package \8216\&3d-graphics-examples\8217"
+                                   , "It is a member of the hidden package \8216\&3d-graphics-examples-1.1.6\8217"
                                    ]
                                    [ ("3d-graphics-examples", T.empty)
                                    , ("3d-graphics-examples", "1.1.6")

plugins/hls-eval-plugin/test/Main.hs

@@ -89,8 +89,8 @@ tests =
   , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs"
   , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"
   , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs"
-  , expectFailBecause "known issue - see a note in P.R. #361" $
-      goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs"
+  -- TODO: known issue - see a note in P.R. #361
+  , goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs"
   , testCase ":type handles a multilined result properly" $
       evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [
         "-- fun",

plugins/hls-eval-plugin/test/testdata/T20.expected.hs

@@ -4,4 +4,4 @@ import Data.Word (Word)
 default (Word)
 
 -- >>> :type  +d   40+ 2 
--- 40+ 2 :: Word
+-- 40+ 2 :: Integer

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

@@ -40,10 +40,9 @@ tests = testGroup "Explicit fixity"
     , hoverTest "signature" (Position 35 2) "infixr 9 `>>>:`"
     , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`"
     , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`"
-    -- Ensure that there is no one extra new line in import statement
-    , expectFail $ hoverTest "import" (Position 2 18) "Control.Monad***"
-    -- Known issue, See https://github.com/haskell/haskell-language-server/pull/2973/files#r916535742
-    , expectFail $ hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"
+    -- TODO: Ensure that there is no one extra new line in import statement
+    , hoverTest "import" (Position 2 18) "Control.Monad\n\n"
+    , hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"
     ]
 
 hoverTest :: TestName -> Position -> T.Text -> TestTree

plugins/hls-explicit-imports-plugin/test/Main.hs

@@ -7,6 +7,7 @@ module Main
   ) where
 
 import           Control.Lens                  ((^.))
+import           Control.Monad                 (unless)
 import           Data.Either.Extra
 import           Data.Foldable                 (find)
 import           Data.Text                     (Text)
@@ -47,7 +48,7 @@ main = defaultTestRunner $ testGroup "import-actions"
     , inlayHintsTestWithoutCap "ExplicitOnlyThis" 3 $ (@=?) []
     -- Only when the client does not support inlay hints, explicit will be provided by code lens
     , codeLensGoldenTest codeActionNoInlayHintsCaps notRefineImports "ExplicitUsualCase" 0
-    , expectFail $ codeLensGoldenTest codeActionNoResolveCaps notRefineImports "ExplicitUsualCase" 0
+    , noCodeLensTest codeActionNoResolveCaps "ExplicitUsualCase"
     , codeActionBreakFile "ExplicitBreakFile" 4 0
     , inlayHintsTestWithCap "ExplicitBreakFile" 3 $ (@=?)
         [mkInlayHint (Position 3 16) "( a1 )"
@@ -193,6 +194,23 @@ codeLensGoldenTest caps predicate fp i = goldenWithImportActions " code lens" fp
   (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i)
   executeCmd c
 
+noCodeLensTest :: ClientCapabilities -> FilePath -> TestTree
+noCodeLensTest caps fp = do
+  testCase (fp ++ " no code lens") $ run $ \_ -> do
+    doc <- openDoc (fp ++ ".hs") "haskell"
+    codeLenses <- getCodeLenses doc
+    resolvedCodeLenses <- for codeLenses resolveCodeLens
+    unless (null resolvedCodeLenses) $
+      liftIO (assertFailure "Unexpected code lens")
+  where
+    run = runSessionWithTestConfig def
+         { testDirLocation = Left testDataDir
+         , testConfigCaps = caps
+         , testLspConfig = def
+         , testPluginDescriptor = explicitImportsPlugin
+         }
+
+
 notRefineImports :: CodeLens -> Bool
 notRefineImports (CodeLens _ (Just (Command text _ _)) _)
   | "Refine imports to" `T.isPrefixOf` text = False