From 2aa5356218b44cffdb4034d739173418823e81e6 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 19 Jan 2021 23:20:42 +0000 Subject: [PATCH 1/6] 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. --- ghcide/test/exe/Main.hs | 52 +++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 25 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index fb6befc6d2..00deefad47 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 @@ -881,9 +881,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 +906,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 +934,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 +962,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 +989,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 +1015,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 +1038,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 +1062,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 +1079,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" @@ -4425,3 +4421,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 From 7362a905e3de84a69b05e3e26895fd1f48936e4d Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 19 Jan 2021 23:21:47 +0000 Subject: [PATCH 2/6] Add code action for disabling a warning --- ghcide/src/Development/IDE/GHC/Warnings.hs | 17 ++++- .../src/Development/IDE/Plugin/CodeAction.hs | 24 +++++++ ghcide/test/exe/Main.hs | 65 ++++++++++++++++++- 3 files changed, 101 insertions(+), 5 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 00deefad47..9761b06728 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -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 @@ -1437,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 @@ -2188,7 +2241,7 @@ 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 warning\")" $ length actionsOrCommands == 1 in testGroup "remove redundant function constraints" [ check @@ -4033,7 +4086,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 @@ -4044,7 +4100,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" + ] ] From 86a8192a6174109fb94e7110356e13f64cfa358a Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 20 Jan 2021 18:30:42 +0000 Subject: [PATCH 3/6] Fix test --- ghcide/test/exe/Main.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9761b06728..b0e4f72abe 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -49,7 +49,7 @@ import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra import System.Directory import System.Exit (ExitCode(ExitSuccess)) -import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) +import System.Process.Extra (readProcess, readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck import Test.QuickCheck.Instances () @@ -2241,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 (other than \"disable warning\")" $ length actionsOrCommands == 1 + 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 From 4cfe26125112d986e80726c358db5f38cb78df67 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 20 Jan 2021 18:31:25 +0000 Subject: [PATCH 4/6] Remove redundant import --- ghcide/test/exe/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index b0e4f72abe..f2d3e78b57 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -49,7 +49,6 @@ import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra import System.Directory import System.Exit (ExitCode(ExitSuccess)) -import System.Process.Extra (readProcess, readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck import Test.QuickCheck.Instances () From 3cc3ba0ad68bb94f419322b06eb4f06372c4dbb0 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 20 Jan 2021 18:32:44 +0000 Subject: [PATCH 5/6] Fix imports --- ghcide/test/exe/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f2d3e78b57..6101e29e11 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -49,6 +49,7 @@ import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra import System.Directory import System.Exit (ExitCode(ExitSuccess)) +import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck import Test.QuickCheck.Instances () From 591f6f5e0850e8650b0dffb7b6255829e46cdb10 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 20 Jan 2021 21:54:59 +0000 Subject: [PATCH 6/6] Fix more tests --- test/functional/Class.hs | 1 + test/functional/FunctionalCodeAction.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) 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 @?=