diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index cd58fd5ead..56e9af103a 100644 --- a/ghcide/test/exe/Config.hs +++ b/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 diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 63d8dd7ab7..66115c16ae 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/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 = diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 013cecaa81..50c263c4fc 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/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 diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 2ca477d896..1193b2dd19 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/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 - diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs index be899e517e..0e458b2163 100644 --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal index 28f8e040cf..933669a483 100644 --- a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal +++ b/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 diff --git a/plugins/hls-cabal-plugin/test/CabalAdd.hs b/plugins/hls-cabal-plugin/test/CabalAdd.hs index f6bc7dbde0..d2804b481c 100644 --- a/plugins/hls-cabal-plugin/test/CabalAdd.hs +++ b/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") diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 85c6980849..f2adf6cb85 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/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", diff --git a/plugins/hls-eval-plugin/test/testdata/T20.expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.expected.hs index 18d2155560..36c93b99c1 100644 --- a/plugins/hls-eval-plugin/test/testdata/T20.expected.hs +++ b/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 diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs index 947570690b..7ed9a67e97 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs index 6cfcc16c60..26e94091cd 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -40,17 +41,30 @@ 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 + , 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" diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 440010bad2..01fe1d469e 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index aa5b5a2a4c..6198d8354e 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -39,7 +39,6 @@ import qualified System.IO.Extra import System.IO.Extra hiding (withTempDir) import System.Time.Extra import Test.Tasty -import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Text.Regex.TDFA ((=~)) @@ -337,67 +336,61 @@ insertImportTests = testGroup "insert import" "WhereDeclLowerInFileWithCommentsBeforeIt.hs" "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" "import Data.Int" - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top with spaces" - "ShebangNotAtTopWithSpaces.hs" - "ShebangNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top no space" - "ShebangNotAtTopNoSpace.hs" - "ShebangNotAtTopNoSpace.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top with spaces" - "OptionsNotAtTopWithSpaces.hs" - "OptionsNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for " - ++ "case when shebang is not placed at top of file") - (checkImport - "Shebang not at top of file" - "ShebangNotAtTop.hs" - "ShebangNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top of file" - "OptionsPragmaNotAtTop.hs" - "OptionsPragmaNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top with comment at top" - "PragmaNotAtTopWithCommentsAtTop.hs" - "PragmaNotAtTopWithCommentsAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top multiple comments" - "PragmaNotAtTopMultipleComments.hs" - "PragmaNotAtTopMultipleComments.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" - (checkImport - "after multiline language pragmas" - "MultiLinePragma.hs" - "MultiLinePragma.expected.hs" - "import Data.Monoid") + -- TODO: 'findNextPragmaPosition' function doesn't account for case when shebang is not + -- placed at top of file" + , checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case when shebang is not + -- placed at top of file" + , checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when shebang is not placed + -- at top of file + , checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC is not + -- placed at top of file + , checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case of multiline pragmas + , checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid" , checkImport "pragmas not at top with module declaration" "PragmaNotAtTopWithModuleDecl.hs" @@ -1513,26 +1506,47 @@ extendImportTests = testGroup "extend import actions" , "x :: (:~:) [] []" , "x = Refl" ]) - , expectFailBecause "importing pattern synonyms is unsupported" - $ testSession "extend import list with pattern synonym" $ template - [("ModuleA.hs", T.unlines - [ "{-# LANGUAGE PatternSynonyms #-}" - , "module ModuleA where" - , "pattern Some x = Just x" - ]) - ] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import A ()" - , "k (Some x) = x" - ]) - (Range (Position 2 3) (Position 2 7)) - ["Add pattern Some to the import list of A"] - (T.unlines - [ "module ModuleB where" - , "import A (pattern Some)" - , "k (Some x) = x" - ]) + -- TODO: importing pattern synonyms is unsupported + , testSessionExpectFail "extend import list with pattern synonym" + (BrokenIdeal $ + template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ] + ) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ] + ) + ) + (BrokenCurrent $ + noCodeActionsTemplate + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ] + ) + (Range (Position 2 3) (Position 2 7)) + ) , ignoreForGhcVersions [GHC94] "Diagnostic message has no suggestions" $ testSession "type constructor name same as data constructor name" $ template [("ModuleA.hs", T.unlines @@ -1601,19 +1615,10 @@ extendImportTests = testGroup "extend import actions" codeActionTitle CodeAction{_title=x} = x template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - configureCheckProject overrideCheckProject + docB <- evalProject setUpModules moduleUnderTest + codeActions <- codeActions docB range + let actualTitles = codeActionTitle <$> codeActions - mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules - docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) - _ <- waitForDiagnostics - waitForProgressDone - actionsOrCommands <- getCodeActions docB range - let codeActions = - [ ca | InR ca <- actionsOrCommands - , let title = codeActionTitle ca - , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) - ] - actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the -- order of the expected actions indicates which one we'll execute -- in this test, i.e., the first one. @@ -1628,6 +1633,30 @@ extendImportTests = testGroup "extend import actions" contentAfterAction <- documentContents docB liftIO $ expectedContentB @=? contentAfterAction + noCodeActionsTemplate setUpModules moduleUnderTest range = do + docB <- evalProject setUpModules moduleUnderTest + codeActions' <- codeActions docB range + let actualTitles = codeActionTitle <$> codeActions' + liftIO $ [] @=? actualTitles + + evalProject setUpModules moduleUnderTest = do + configureCheckProject overrideCheckProject + + mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + + pure docB + + codeActions docB range = do + actionsOrCommands <- getCodeActions docB range + pure $ + [ ca | InR ca <- actionsOrCommands + , let title = codeActionTitle ca + , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) + ] + fixModuleImportTypoTests :: TestTree fixModuleImportTypoTests = testGroup "fix module import typo" [ testSession "works when single module suggested" $ do @@ -1787,7 +1816,8 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" ] - , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + -- TODO: Importing pattern synonyms is unsupported + , test False [] "k (Some x) = x" [] "import B (pattern Some)" ] where test = test' False @@ -3804,6 +3834,13 @@ assertActionWithTitle actions title = testSession :: TestName -> Session () -> TestTree testSession name = testCase name . run +testSessionExpectFail + :: TestName + -> ExpectBroken 'Ideal (Session ()) + -> ExpectBroken 'Current (Session ()) + -> TestTree +testSessionExpectFail name _ = testSession name . unCurrent + testSessionWithExtraFiles :: HasCallStack => FilePath -> TestName -> (FilePath -> Session ()) -> TestTree testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs index ca0b9f28dc..e9e8f4f604 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs @@ -3,8 +3,8 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} {-# OPTIONS_GHC -Wall, - -Wno-unused-imports #-} import Data.Monoid + -Wno-unused-imports #-} -- some comment diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs index 912d6a210c..8595bca913 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections #-} -import Data.Monoid @@ -11,6 +10,7 @@ class Semigroup a => SomeData a instance SomeData All {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs index 55a6c60dbb..a92bbab580 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs @@ -1,8 +1,8 @@ -import Data.Monoid class Semigroup a => SomeData a instance SomeData All {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs index eead1cb55e..cbe451714d 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs @@ -9,7 +9,6 @@ comment -} {-# LANGUAGE TupleSections #-} -import Data.Monoid {- some comment -} -- again @@ -18,6 +17,7 @@ instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs index 57fc1614be..57ab794a7e 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs @@ -4,7 +4,6 @@ -- another comment {-# LANGUAGE TupleSections #-} -import Data.Monoid {- some comment -} @@ -13,6 +12,7 @@ instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs index 09e503ddd3..230710232e 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -import Data.Monoid class Semigroup a => SomeData a instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid f :: Int -> Int f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs index b367314238..c5977503a6 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs @@ -1,8 +1,8 @@ -import Data.Monoid class Semigroup a => SomeData a instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid f :: Int -> Int f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs index 4c6cbe3917..8d358468da 100644 --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TupleSections #-} -import Data.Monoid @@ -16,6 +15,7 @@ instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 9d11cff3a5..445683366c 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -8,12 +8,13 @@ import Control.Monad import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.Map as Map +import qualified Data.Text as T import Data.Typeable (Typeable) import Development.IDE (RuleResult, action, define, getFilesOfInterestUntracked, getPluginConfigAction, ideErrorText, uses_) -import Development.IDE.Test (expectDiagnostics) +import Development.IDE.Test (Cursor, expectDiagnostics) import GHC.Generics import Ide.Plugin.Config import Ide.Types @@ -43,13 +44,15 @@ genericConfigTests = testGroup "generic plugin config" setHlsConfig $ changeConfig "someplugin" def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics standardDiagnostics - , expectFailBecause "partial config is not supported" $ - testCase "custom defaults and non overlapping user config" $ runConfigSession "diagnostics" $ do + -- TODO: Partial config is not supported + , testCase "custom defaults and non overlapping user config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config doesn't accidentally override the initial config setHlsConfig $ changeConfig testPluginId def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled - expectDiagnostics standardDiagnostics + expectDiagnosticsFail + (BrokenIdeal standardDiagnostics) + (BrokenCurrent testPluginDiagnostics) , testCase "custom defaults and overlapping user plugin config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config overrides the default initial config @@ -104,3 +107,10 @@ data GetTestDiagnostics = GetTestDiagnostics instance Hashable GetTestDiagnostics instance NFData GetTestDiagnostics type instance RuleResult GetTestDiagnostics = () + +expectDiagnosticsFail + :: HasCallStack + => ExpectBroken 'Ideal [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] + -> ExpectBroken 'Current [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] + -> Session () +expectDiagnosticsFail _ = expectDiagnostics . unCurrent