From f03a7fa55d909c864771f0989abace8793b5b15a Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 21 Jan 2021 23:11:13 +0000 Subject: [PATCH] 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 | 17 ++- .../src/Development/IDE/Plugin/CodeAction.hs | 24 ++++ ghcide/test/exe/Main.hs | 122 ++++++++++++++---- test/functional/Class.hs | 1 + test/functional/FunctionalCodeAction.hs | 2 +- 5 files changed, 135 insertions(+), 31 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 68c52cf982..7ff1bc8e4d 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 2422ccc64d..f6ac664aa5 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index fb6befc6d2..6101e29e11 100644 --- a/ghcide/test/exe/Main.hs +++ b/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 diff --git a/test/functional/Class.hs b/test/functional/Class.hs index e02a0440ad..4d02ad4e41 100644 --- a/test/functional/Class.hs +++ b/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 diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 5054159396..ed99206f17 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/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 @?=