From c68356b478b033e8827e852b9ac427841aef804a Mon Sep 17 00:00:00 2001 From: agam263 Date: Thu, 2 Apr 2026 03:09:29 +0530 Subject: [PATCH] Fix deleting unused bindings with Haddock docs --- .../src/Development/IDE/Plugin/CodeAction.hs | 58 +++++++++++++++++-- plugins/hls-refactor-plugin/test/Main.hs | 37 ++++++++++++ 2 files changed, 90 insertions(+), 5 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index a1ec99167d..82eefc9dd7 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -599,14 +599,16 @@ suggestDeleteUnusedBinding -- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" , Just indexedContent <- indexedByPosition . T.unpack <$> contents - = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) + = let edits = flip TextEdit "" <$> mergeRanges (sortOn _start $ relatedRanges indexedContent (T.unpack name)) in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) | otherwise = [] where relatedRanges indexedContent name = concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls toRange = realSrcSpanToRange - extendForSpaces = extendToIncludePreviousNewlineIfPossible + extendForDeletion indexedContent = + extendToIncludePreviousNewlineIfPossible indexedContent + . extendToIncludeAssociatedHaddock contents findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] findRelatedSpans @@ -618,7 +620,7 @@ suggestDeleteUnusedBinding let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in - extendForSpaces indexedContent (toRange l) : + extendForDeletion indexedContent (toRange l) : concatMap (findSig . reLoc) hsmodDecls _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpans _ _ _ = [] @@ -637,7 +639,7 @@ suggestDeleteUnusedBinding findRelatedSigSpan indexedContent name l sig = let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of - Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int + Just (_span, True) -> pure $ extendForDeletion indexedContent $ toRange l -- a :: Int Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] @@ -700,7 +702,7 @@ suggestDeleteUnusedBinding then let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] - in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs + in extendForDeletion indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpanForHsBind _ _ _ _ = [] @@ -710,6 +712,52 @@ suggestDeleteUnusedBinding isSameName :: IdP GhcPs -> String -> Bool isSameName x name = T.unpack (printOutputable x) == name +extendToIncludeAssociatedHaddock :: Maybe T.Text -> Range -> Range +extendToIncludeAssociatedHaddock Nothing range = range +extendToIncludeAssociatedHaddock (Just source) range = + maybe range (\line -> range { _start = Position line 0 }) $ + attachedHaddockStartLine (T.lines source) (_start range) + +attachedHaddockStartLine :: [T.Text] -> Position -> Maybe UInt +attachedHaddockStartLine sourceLines startPos + | startLine <= 0 = Nothing + | otherwise = + let preceding = take startLine sourceLines + in case reverse preceding of + prevLine : _ + | isLineComment (T.stripStart prevLine) -> + let commentBlock = takeWhile (isLineComment . T.stripStart) (reverse preceding) + in case reverse commentBlock of + [] -> Nothing + firstLine : _ + | isHaddockLineStart (T.stripStart firstLine) + -> Just . fromIntegral $ startLine - length commentBlock + _ -> Nothing + | isBlockCommentEnd (T.stripStart prevLine) -> + let block = takeUntilBlockHaddockStart (reverse preceding) + in case block of + firstLine : _ + | isHaddockBlockStart (T.stripStart firstLine) + -> Just . fromIntegral $ startLine - length block + _ -> Nothing + | otherwise -> Nothing + [] -> Nothing + where + startLine = fromIntegral (_line startPos) + + isLineComment = T.isPrefixOf (T.pack "--") + isHaddockLineStart txt = any (`T.isPrefixOf` txt) [T.pack "-- |", T.pack "-- ^"] + isBlockCommentEnd txt = T.isSuffixOf (T.pack "-}") txt + isHaddockBlockStart txt = any (`T.isPrefixOf` txt) [T.pack "{-|", T.pack "{-^"] + + takeUntilBlockHaddockStart = go [] + where + go acc [] = acc + go acc (line:rest) + | T.null (T.strip line) = [] + | isHaddockBlockStart (T.stripStart line) = line : acc + | otherwise = go (line : acc) rest + data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll deriving (Eq) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 8c73eab52e..fdfec87dba 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -2531,6 +2531,43 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action" , "" , "some = ()" ] + , testSession "delete unused top level binding with Haddock comment" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "-- | docs for f" + , "f :: Int" + , "f = 1" + , "" + , "some = ()" + ] + (5, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] + , testSession "delete unused top level binding with block Haddock comment" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "{-| docs for f" + , "-}" + , "f :: Int" + , "f = 1" + , "" + , "some = ()" + ] + (6, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] , testSession "delete unused binding in where clause" $ testFor [ "{-# OPTIONS_GHC -Wunused-binds #-}"