Replace some expectFail references with explicit checks

haskell · Sep 14, 2024 · acd0b2c · acd0b2c
1 parent f628754
commit acd0b2c
Show file tree

Hide file tree

Showing 12 changed files with 88 additions and 77 deletions.
diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/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

diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs
@@ -17,6 +17,7 @@ import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
 import           System.FilePath               ((</>))
 import           Test.Hls
+import Control.Monad (unless)
 
 explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log
 explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports"
@@ -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
@@ -337,67 +337,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"

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
@@ -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
@@ -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
@@ -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/...hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/...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/...ls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/...ls-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
@@ -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
@@ -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
@@ -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
@@ -43,13 +43,13 @@ 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
+            expectDiagnostics 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