Skip to content

Commit 05170e9

Browse files
georgefstgeorgefst
committed
Add action for ignoring HLint hint for a single definition
1 parent 5a08df6 commit 05170e9

File tree

2 files changed

+57
-19
lines changed

2 files changed

+57
-19
lines changed

‎ghcide/src/Development/IDE/LSP/Outline.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55

66
module Development.IDE.LSP.Outline
77
( moduleOutline
8+
, documentSymbolForDecl
89
)
910
where
1011

@@ -259,5 +260,3 @@ hsConDeclsBinders cons
259260
get_flds :: Located [LConDeclField GhcPs]
260261
-> [LFieldOcc GhcPs]
261262
get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds)
262-
263-

‎plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs‎

Lines changed: 56 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -38,11 +38,11 @@ import Data.Aeson.Types (FromJSON (.
3838
import qualified Data.ByteString as BS
3939
import Data.Hashable
4040
import qualified Data.HashMap.Strict as Map
41+
import Data.List (find)
4142
import qualified Data.Map as M
4243
import Data.Maybe
4344
import qualified Data.Text as T
4445
import qualified Data.Text.Encoding as T
45-
import Data.Text.Utf16.Rope.Mixed (Rope)
4646
import qualified Data.Text.Utf16.Rope.Mixed as Rope
4747
import Data.Typeable
4848
import Development.IDE hiding
@@ -64,17 +64,30 @@ import System.Environment (setEnv,
6464
#endif
6565

6666
import Development.IDE.GHC.Compat (DynFlags,
67+
pattern RealSrcLoc,
68+
pattern UnhelpfulLoc,
6769
extensionFlags,
70+
getLoc,
71+
hsmodDecls,
6872
ms_hspp_opts,
69-
topDir)
73+
pm_parsed_source,
74+
srcLocLine,
75+
srcSpanStart,
76+
topDir,
77+
unLoc)
7078
import qualified Development.IDE.GHC.Compat.Util as EnumSet
7179

7280
#if MIN_GHC_API_VERSION(9,4,0)
7381
import qualified GHC.Data.Strict as Strict
7482
#endif
7583
#if MIN_GHC_API_VERSION(9,0,0)
7684
import GHC.Types.SrcLoc hiding
77-
(RealSrcSpan)
85+
(RealSrcSpan,
86+
SrcLoc(..),
87+
getLoc,
88+
srcLocLine,
89+
srcSpanStart,
90+
unLoc)
7891
import qualified GHC.Types.SrcLoc as GHC
7992
#else
8093
import qualified SrcLoc as GHC
@@ -111,6 +124,7 @@ import qualified Language.LSP.Protocol.Types as LSP
111124

112125
import Development.IDE.Core.PluginUtils as PluginUtils
113126
import qualified Development.IDE.Core.Shake as Shake
127+
import Development.IDE.LSP.Outline (documentSymbolForDecl)
114128
import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits),
115129
NextPragmaInfo (NextPragmaInfo),
116130
getNextPragmaInfo,
@@ -413,8 +427,8 @@ resolveProvider recorder ideState _plId ca uri resolveValue = do
413427
(ApplyHint verTxtDocId oneHint) -> do
414428
edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId
415429
pure $ ca & LSP.edit ?~ edit
416-
(IgnoreHint verTxtDocId hintTitle ) -> do
417-
edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle
430+
(IgnoreHint verTxtDocId hintTitle scope) -> do
431+
edit <- ExceptT $ liftIO $ ignoreHint scope recorder ideState file verTxtDocId hintTitle
418432
pure $ ca & LSP.edit ?~ edit
419433

420434
applyRefactAvailable :: Bool
@@ -431,7 +445,7 @@ diagnosticToCodeActions verTxtDocId diagnostic
431445
| LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic
432446
, let isHintApplicable = "refact:" `T.isPrefixOf` code && applyRefactAvailable
433447
, let hint = T.replace "refact:" "" code
434-
, let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"
448+
, let suppressHintTitle s = "Ignore hint \"" <> hint <> "\" in this " <> s
435449
, let suppressHintArguments = IgnoreHint verTxtDocId hint
436450
= catMaybes
437451
-- Applying the hint is marked preferred because it addresses the underlying error.
@@ -441,7 +455,8 @@ diagnosticToCodeActions verTxtDocId diagnostic
441455
applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) ->
442456
Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True)
443457
| otherwise -> Nothing
444-
, Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False)
458+
, Just (mkCodeAction (suppressHintTitle "module") diagnostic (Just (toJSON $ suppressHintArguments IgnoreInModule)) False)
459+
, Just (mkCodeAction (suppressHintTitle "definition") diagnostic (Just (toJSON $ suppressHintArguments $ IgnoreInDefinition start)) False)
445460
]
446461
| otherwise = []
447462

@@ -458,27 +473,45 @@ mkCodeAction title diagnostic data_ isPreferred =
458473
, _data_ = data_
459474
}
460475

461-
mkSuppressHintTextEdits :: DynFlags -> Rope -> T.Text -> [LSP.TextEdit]
462-
mkSuppressHintTextEdits dynFlags fileContents hint =
476+
mkSuppressHintTextEdits :: Int -> T.Text -> Maybe LineSplitTextEdits -> Maybe T.Text -> [LSP.TextEdit]
477+
mkSuppressHintTextEdits line hint lineSplitTextEdits defName =
463478
let
464-
NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents)
465-
nextPragmaLinePosition = Position (fromIntegral nextPragmaLine) 0
466-
nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition
467-
textEdit = LSP.TextEdit nextPragmaRange $ "{- HLINT ignore \"" <> hint <> "\" -}\n"
479+
pos = Position (fromIntegral line) 0
480+
range = Range pos pos
481+
textEdit = LSP.TextEdit range $ "{- HLINT ignore " <> foldMap (<> " ") defName <> "\"" <> hint <> "\" -}\n"
468482
lineSplitTextEditList = maybe [] (\LineSplitTextEdits{..} -> [lineSplitInsertTextEdit, lineSplitDeleteTextEdit]) lineSplitTextEdits
469483
in
470484
textEdit : lineSplitTextEditList
471485
-- ---------------------------------------------------------------------
472486

473-
ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)
474-
ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do
487+
ignoreHint :: IgnoreHintScope -> Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)
488+
ignoreHint scope _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do
475489
(_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp
476490
(msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp
477491
case fileContents of
478492
Just contents -> do
479493
let dynFlags = ms_hspp_opts $ msrModSummary msr
480-
textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle
481-
workspaceEdit =
494+
textEdits <- case scope of
495+
IgnoreInModule ->
496+
let NextPragmaInfo{nextPragmaLine, lineSplitTextEdits} = getNextPragmaInfo dynFlags (Just contents)
497+
in pure $ mkSuppressHintTextEdits nextPragmaLine ignoreHintTitle lineSplitTextEdits Nothing
498+
IgnoreInDefinition pos -> do
499+
(pm, _) <- runActionE "Hlint.GetParsedModule" ideState $ useWithStaleE GetParsedModule nfp
500+
let defInfo = do
501+
containingDecl <- find (maybe False (positionInRange pos) . srcSpanToRange . getLoc)
502+
$ hsmodDecls $ unLoc $ pm_parsed_source pm
503+
defStartLine <- case srcSpanStart $ getLoc containingDecl of
504+
-- TODO `srcLocLine` can apparently raise an error, but it's not clear what the safe version is
505+
RealSrcLoc sl _ -> Just (srcLocLine sl - 1)
506+
UnhelpfulLoc _ -> Nothing
507+
-- TODO `documentSymbolForDecl` wasn't intended to be exported, and computes more than we need
508+
-- (although laziness should save us there)
509+
defName <- (^. LSP.name) <$> documentSymbolForDecl containingDecl
510+
pure (defStartLine, defName)
511+
case defInfo of
512+
Nothing -> throwError $ PluginInternalError "bad things happened" -- TODO better error handling
513+
Just (defStartLine, defName) -> pure $ mkSuppressHintTextEdits defStartLine ignoreHintTitle Nothing (Just defName)
514+
let workspaceEdit =
482515
LSP.WorkspaceEdit
483516
(Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits))
484517
Nothing
@@ -497,6 +530,7 @@ data HlintResolveCommands =
497530
| IgnoreHint
498531
{ verTxtDocId :: VersionedTextDocumentIdentifier
499532
, ignoreHintTitle :: HintTitle
533+
, startPosition :: IgnoreHintScope
500534
} deriving (Generic, ToJSON, FromJSON)
501535

502536
type HintTitle = T.Text
@@ -507,6 +541,11 @@ data OneHint =
507541
, oneHintTitle :: HintTitle
508542
} deriving (Generic, Eq, Show, ToJSON, FromJSON)
509543

544+
data IgnoreHintScope
545+
= IgnoreInModule
546+
| IgnoreInDefinition Position
547+
deriving (Generic, ToJSON, FromJSON)
548+
510549
applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
511550
#if !APPLY_REFACT
512551
applyHint _ _ _ _ _ =

0 commit comments

Comments
 (0)