Make "broken" tests explicit

Author: sgillespie

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
@@ -41,15 +42,29 @@ tests = testGroup "Explicit fixity"
     , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`"
     , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`"
     -- TODO: Ensure that there is no one extra new line in import statement
-    , hoverTest "import" (Position 2 18) "Control.Monad\n\n"
+    , hoverTestExpectFail
+        "import"
+        (Position 2 18)
+        (BrokenIdeal "Control.Monad***")
+        (BrokenCurrent "Control.Monad\n\n")
     , hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`"
     ]
 
 hoverTest :: TestName -> Position -> T.Text -> TestTree
 hoverTest = hoverTest' "Hover.hs"
+
 hoverTestImport :: TestName -> Position -> T.Text -> TestTree
 hoverTestImport = hoverTest' "HoverImport.hs"
 
+hoverTestExpectFail
+  :: TestName
+  -> Position
+  -> ExpectBroken 'Ideal T.Text
+  -> ExpectBroken 'Current T.Text
+  -> TestTree
+hoverTestExpectFail title pos _ =
+  hoverTest title pos . unCurrent
+
 hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree
 hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do
     doc <- openDoc docName "haskell"

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

@@ -1507,20 +1507,46 @@ extendImportTests = testGroup "extend import actions"
                     , "x = Refl"
                     ])
         -- TODO: importing pattern synonyms is unsupported
-        -- Ideally the result is "Add pattern Some of the import list of A"
-        , testSession "extend import list with pattern synonym" $ 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))
+        , 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
@@ -3808,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
 

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
@@ -49,7 +50,9 @@ genericConfigTests = testGroup "generic plugin config"
             -- 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 testPluginDiagnostics
+            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