Add code actions for disabling a warning in the current file (#1235)

* Slacken some flaky tests

The properties tested were previously unnecessarily strong and would break witht the addition of irrelevant code actions. We now don't care about position and total quantity of code actions, only that the ones we care about exist.

* Add code action for disabling a warning

* Fix test

* Remove redundant import

* Fix imports

* Fix more tests

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

ghcide/src/Development/IDE/GHC/Warnings.hs

@@ -3,14 +3,16 @@
 
 module Development.IDE.GHC.Warnings(withWarnings) where
 
+import Data.List
 import ErrUtils
-import GhcPlugins as GHC hiding (Var)
+import GhcPlugins as GHC hiding (Var, (<>))
 
 import           Control.Concurrent.Extra
 import qualified           Data.Text as T
 
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.GHC.Error
+import           Language.Haskell.LSP.Types (NumberOrString (StringValue))
 
 
 -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some
@@ -27,8 +29,19 @@ withWarnings diagSource action = do
   warnings <- newVar []
   let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
       newAction dynFlags wr _ loc style msg = do
-        let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg
+        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg
         modifyVar_ warnings $ return . (wr_d:)
   res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}
   warns <- readVar warnings
   return (reverse $ concat warns, res)
+
+attachReason :: WarnReason -> Diagnostic -> Diagnostic
+attachReason wr d = d{_code = StringValue <$> showReason wr}
+ where
+  showReason = \case
+    NoReason -> Nothing
+    Reason flag -> showFlag flag
+    ErrReason flag -> showFlag =<< flag
+
+showFlag :: WarningFlag -> Maybe T.Text
+showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -203,6 +203,7 @@ suggestAction packageExports ideOptions parsedModule text diag = concat
     ++ suggestNewImport packageExports pm diag
     ++ suggestDeleteUnusedBinding pm text diag
     ++ suggestExportUnusedTopBinding text pm diag
+    ++ suggestDisableWarning pm text diag
     | Just pm <- [parsedModule]
     ] ++
     suggestFillHole diag                   -- Lowest priority
@@ -226,6 +227,15 @@ findInstanceHead df instanceHead decls =
 findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a)
 findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l)
 
+suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestDisableWarning pm contents Diagnostic{..}
+    | Just (StringValue (T.stripPrefix "-W" -> Just w)) <- _code =
+        pure
+            ( "Disable \"" <> w <> "\" warnings"
+            , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"]
+            )
+    | otherwise = []
+
 suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
 --     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
@@ -1247,3 +1257,17 @@ importStyles IdentInfo {parent, rendered, isDatacon}
 renderImportStyle :: ImportStyle -> T.Text
 renderImportStyle (ImportTopLevel x) = x
 renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"
+
+-- | Find the first non-blank line before the first of (module name / imports / declarations).
+-- Useful for inserting pragmas.
+endOfModuleHeader :: ParsedModule -> Maybe T.Text -> Range
+endOfModuleHeader pm contents =
+    let mod = unLoc $ pm_parsed_source pm
+        modNameLoc = getLoc <$> hsmodName mod
+        firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod)
+        firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod)
+        line = fromMaybe 0 $ firstNonBlankBefore . _line . _start =<< srcSpanToRange =<<
+            modNameLoc <|> firstImportLoc <|> firstDeclLoc
+        firstNonBlankBefore n = (n -) . fromMaybe 0 . findIndex (not . T.null) . reverse . take n . T.lines <$> contents
+        loc = Position line 0
+     in Range loc loc

ghcide/test/exe/Main.hs

@@ -14,7 +14,7 @@ import Control.Applicative.Combinators
 import Control.Exception (bracket_, catch)
 import qualified Control.Lens as Lens
 import Control.Monad
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson (FromJSON, Value, toJSON)
 import qualified Data.Binary as Binary
 import Data.Default
@@ -64,6 +64,7 @@ import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockS
 import Control.Monad.Extra (whenJust)
 import qualified Language.Haskell.LSP.Types.Lens as L
 import Control.Lens ((^.))
+import Data.Functor
 
 main :: IO ()
 main = do
@@ -676,6 +677,7 @@ codeActionTests = testGroup "code actions"
   , removeImportTests
   , extendImportTests
   , suggestImportTests
+  , disableWarningTests
   , fixConstructorImportTests
   , importRenameActionTests
   , fillTypedHoleTests
@@ -881,9 +883,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -907,9 +908,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -936,9 +936,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove stuffA, stuffC from import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -965,9 +964,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove !!, <?> from import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove !!, <?> from import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -993,9 +991,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove A from import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A from import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -1020,9 +1017,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove A, E, F from import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A, E, F from import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -1044,9 +1040,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       docB <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")
+        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents docB
       let expectedContentAfterAction = T.unlines
@@ -1069,9 +1064,8 @@ removeImportTests = testGroup "remove import actions"
             ]
       doc <- createDoc "ModuleC.hs" "haskell" content
       _ <- waitForDiagnostics
-      [_, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }]
-          <- getCodeActions doc (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove all redundant imports" @=? actionTitle
+      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove all redundant imports")
+        =<< getCodeActions doc (Range (Position 2 0) (Position 2 5))
       executeCodeAction action
       contentAfterAction <- documentContents doc
       let expectedContentAfterAction = T.unlines
@@ -1087,6 +1081,10 @@ removeImportTests = testGroup "remove import actions"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
   ]
+  where
+    caWithTitle t = \case
+      CACodeAction a@CodeAction{_title} -> guard (_title == t) >> Just a
+      _ -> Nothing
 
 extendImportTests :: TestTree
 extendImportTests = testGroup "extend import actions"
@@ -1441,6 +1439,57 @@ suggestImportTests = testGroup "suggest import actions"
           else
               liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
 
+disableWarningTests :: TestTree
+disableWarningTests =
+  testGroup "disable warnings" $
+    [
+      ( "missing-signatures"
+      , T.unlines
+          [ "{-# OPTIONS_GHC -Wall #-}"
+          , "main = putStrLn \"hello\""
+          ]
+      , T.unlines
+          [ "{-# OPTIONS_GHC -Wall #-}"
+          , "{-# OPTIONS_GHC -Wno-missing-signatures #-}"
+          , "main = putStrLn \"hello\""
+          ]
+      )
+    ,
+      ( "unused-imports"
+      , T.unlines
+          [ "{-# OPTIONS_GHC -Wall #-}"
+          , ""
+          , ""
+          , "module M where"
+          , ""
+          , "import Data.Functor"
+          ]
+      , T.unlines
+          [ "{-# OPTIONS_GHC -Wall #-}"
+          , "{-# OPTIONS_GHC -Wno-unused-imports #-}"
+          , ""
+          , ""
+          , "module M where"
+          , ""
+          , "import Data.Functor"
+          ]
+      )
+    ]
+      <&> \(warning, initialContent, expectedContent) -> testSession (T.unpack warning) $ do
+        doc <- createDoc "Module.hs" "haskell" initialContent
+        _ <- waitForDiagnostics
+        codeActs <- mapMaybe caResultToCodeAct <$> getCodeActions doc (Range (Position 0 0) (Position 0 0))
+        case find (\CodeAction{_title} -> _title == "Disable \"" <> warning <> "\" warnings") codeActs of
+          Nothing -> liftIO $ assertFailure "No code action with expected title"
+          Just action -> do
+            executeCodeAction action
+            contentAfterAction <- documentContents doc
+            liftIO $ expectedContent @=? contentAfterAction
+ where
+  caResultToCodeAct = \case
+    CACommand _ -> Nothing
+    CACodeAction c -> Just c
+
 insertNewDefinitionTests :: TestTree
 insertNewDefinitionTests = testGroup "insert new definition actions"
   [ testSession "insert new function definition" $ do
@@ -2192,7 +2241,12 @@ removeRedundantConstraintsTests = let
     doc <- createDoc "Testing.hs" "haskell" code
     _ <- waitForDiagnostics
     actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound))
-    liftIO $ assertBool "Found some actions" (null actionsOrCommands)
+    liftIO $ assertBool "Found some actions (other than \"disable warnings\")"
+      $ all isDisableWarningAction actionsOrCommands
+    where
+      isDisableWarningAction = \case
+        CACodeAction CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title
+        _ -> False
 
   in testGroup "remove redundant function constraints"
   [ check
@@ -4037,7 +4091,10 @@ asyncTests = testGroup "async"
               ]
             void waitForDiagnostics
             actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))
-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=?
+              [ "add signature: foo :: a -> a"
+              , "Disable \"missing-signatures\" warnings"
+              ]
     , testSession "request" $ do
             -- Execute a custom request that will block for 1000 seconds
             void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000
@@ -4048,7 +4105,10 @@ asyncTests = testGroup "async"
               ]
             void waitForDiagnostics
             actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))
-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=?
+              [ "add signature: foo :: a -> a"
+              , "Disable \"missing-signatures\" warnings"
+              ]
     ]
 
 
@@ -4425,3 +4485,9 @@ withTempDir :: (FilePath -> IO a) -> IO a
 withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
   dir' <- canonicalizePath dir
   f dir'
+
+-- | Assert that a value is not 'Nothing', and extract the value.
+assertJust :: MonadIO m => String -> Maybe a -> m a
+assertJust s = \case
+  Nothing -> liftIO $ assertFailure s
+  Just x -> pure x

test/functional/Class.hs

@@ -32,6 +32,7 @@ tests = testGroup
           @?=
           [ Just "Add placeholders for '=='"
           , Just "Add placeholders for '/='"
+          , Just "Disable \"missing-methods\" warnings"
           ]
   , glodenTest "Creates a placeholder for '=='" "T1" "eq"
     $ \(eqAction:_) -> do

test/functional/FunctionalCodeAction.hs

@@ -367,7 +367,7 @@ redundantImportTests = testGroup "redundant import code actions" [
     , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
         doc <- openDoc "src/MultipleImports.hs" "haskell"
         _   <- waitForDiagnosticsFromSource doc "typecheck"
-        CACommand cmd : _ <- getAllCodeActions doc
+        _ : CACommand cmd : _ <- getAllCodeActions doc
         executeCommand cmd
         contents <- documentContents doc
         liftIO $ T.lines contents @?=