Skip to content
This repository was archived by the owner on Jan 2, 2021. It is now read-only.

Add code actions for disabling a warning in the current file #897

Closed
wants to merge 7 commits into from
Closed

Add code actions for disabling a warning in the current file #897

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
53bbfe1
Add code action for disabling a warning
georgefst Nov 7, 2020
85128c9
Use flag as code field
georgefst Nov 14, 2020
d007049
Add tests for disabling warnings
georgefst Nov 14, 2020
1437c49
Insert pragma below existing pragmas
georgefst Nov 15, 2020
b31bf50
Implement 'showFlag' explicitly
georgefst Dec 18, 2020
95aa3b3
Use 'wWarningFlags' to avoid hardcoding 'showFlag'
georgefst Dec 27, 2020
64a0aa5
Fix tests
georgefst Dec 28, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 15 additions & 2 deletions src/Development/IDE/GHC/Warnings.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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}
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This seems pretty weird, especially since the specification says this field may be displayed to the user. Perhaps the reason can be recorded in the ide state, and the code action can be generated based off of that?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This seems pretty weird, especially since the specification says this field may be displayed to the user.

Hmm, yeah, that is unfortunate. I was originally intending to use the more human-readable form here, analogously to how GHC shows e.g. -Wunused-imports in the CLI output. But this way it was easier to be sure that a particular diagnostic comes from a GHC warning (using T.stripPrefix "Opt_Warn").

Perhaps the reason can be recorded in the ide state, and the code action can be generated based off of that?

That sounds promising. There's a diagnostics field in ShakeExtras but the DiagnosticStore type doesn't seem to give us anywhere to store extra information, so I guess it would need replacing - I haven't yet looked at how much of a knock-on effect that might have.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm struggling to see a nice way to put this information in ShakeExtras.

Besides, based on other LSP servers, I think this actually is more or less the intended use case for the code field. I'm thinking we put the full flag there e.g. -Wunused-imports, and trigger the action for diagnostics whose code begins with "-W" Still a little bit ugly, but the very nature of LSP means we're bound to be resigned to the occasional but of string-ly typed code.

The way VScode at least shows this is actually quite nice: typecheck(-Wunused-imports). Regardless of the original purpose of this PR, it's nice to get this extra information about where a warning is coming from. In fact, it's the one thing in GHC's output that we're currently missing.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm thinking we put the full flag there e.g. -Wunused-imports

This is what c2cd237 does.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The code field is intended to refer to the "handbook code" for a diagnostic, as provided by some compilers. Version 3.16 of the spec has a data field for this, prompted from microsoft/language-server-protocol#887. Perhaps use that instead.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think seeing as the flag is the closest thing to a "handbook code" GHC is likely to have any time soon, this is still the right place to put it. Especially given that the result is visually appealing in VScode (haven't tried other editors, but I'd hope they show something relatively similar).

Obviously I'll change this if you or any of the other core maintainers feel strongly.

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
27 changes: 25 additions & 2 deletions src/Development/IDE/Plugin/CodeAction.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -169,10 +169,19 @@ 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

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"
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Exact wording of message is bikeshed-able

, [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,..}
Expand Down Expand Up @@ -968,8 +977,8 @@ extractQualifiedModuleName :: T.Text -> Maybe T.Text
extractQualifiedModuleName x
| Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"
= Just m
| otherwise
= Nothing
| otherwise
= Nothing

-------------------------------------------------------------------------------------------------

Expand Down Expand Up @@ -1175,3 +1184,17 @@ renderIdentInfo :: IdentInfo -> T.Text
renderIdentInfo IdentInfo {parent, rendered}
| Just p <- parent = p <> "(" <> rendered <> ")"
| otherwise = rendered

-- | 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
79 changes: 68 additions & 11 deletions test/exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, Value, toJSON)
import qualified Data.Binary as Binary
import Data.Foldable
import Data.Functor
import Data.List.Extra
import Data.Maybe
import Data.Rope.UTF16 (Rope)
Expand Down Expand Up @@ -650,6 +651,7 @@ codeActionTests = testGroup "code actions"
, removeImportTests
, extendImportTests
, suggestImportTests
, disableWarningTests
, fixConstructorImportTests
, importRenameActionTests
, fillTypedHoleTests
Expand Down Expand Up @@ -854,7 +856,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove import" @=? actionTitle
executeCodeAction action
Expand All @@ -880,7 +882,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove import" @=? actionTitle
executeCodeAction action
Expand Down Expand Up @@ -909,7 +911,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
executeCodeAction action
Expand Down Expand Up @@ -938,7 +940,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove !!, <?> from import" @=? actionTitle
executeCodeAction action
Expand Down Expand Up @@ -966,7 +968,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove A from import" @=? actionTitle
executeCodeAction action
Expand All @@ -993,7 +995,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove A, E, F from import" @=? actionTitle
executeCodeAction action
Expand All @@ -1017,7 +1019,7 @@ removeImportTests = testGroup "remove import actions"
]
docB <- createDoc "ModuleB.hs" "haskell" contentB
_ <- waitForDiagnostics
[CACodeAction action@CodeAction { _title = actionTitle }, _]
[_, CACodeAction action@CodeAction { _title = actionTitle }, _]
<- getCodeActions docB (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove import" @=? actionTitle
executeCodeAction action
Expand All @@ -1042,7 +1044,7 @@ removeImportTests = testGroup "remove import actions"
]
doc <- createDoc "ModuleC.hs" "haskell" content
_ <- waitForDiagnostics
[_, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }]
[_, _, _, _, _, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }]
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is particularly nasty.

<- getCodeActions doc (Range (Position 2 0) (Position 2 5))
liftIO $ "Remove all redundant imports" @=? actionTitle
executeCodeAction action
Expand Down Expand Up @@ -1333,6 +1335,55 @@ 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
Expand Down Expand Up @@ -1963,7 +2014,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" $ length actionsOrCommands == 1

in testGroup "remove redundant function constraints"
[ check
Expand Down Expand Up @@ -3757,7 +3808,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
Expand All @@ -3768,7 +3822,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"
]
]


Expand Down