From 7c2edbc97ed0d5ccf68f51590f4e3346c89442f6 Mon Sep 17 00:00:00 2001 From: vidit-od Date: Wed, 1 Apr 2026 13:35:51 +0530 Subject: [PATCH 1/2] Removes Haddock comments above a Deleted Unused Defination Haddock comments can be written in two ways. with single line comments and multi line commetns. These comments are located exactly above a functions signature. This commit introduces code to delete these haddock comments for unused defination deletion codeaction. --- .../src/Development/IDE/Plugin/CodeAction.hs | 27 ++-- .../IDE/Plugin/CodeAction/PositionIndexed.hs | 127 ++++++++++++++++-- 2 files changed, 135 insertions(+), 19 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..8c89070762 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -598,9 +598,14 @@ suggestDeleteUnusedBinding Diagnostic{_range=_range,..} -- 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) - in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) + , Just indexedContent <- indexedByPosition . T.unpack <$> contents = + let nameStr = T.unpack name + ranges = + mergeRanges + . sortOn _start + $ relatedRanges indexedContent nameStr + edits = flip TextEdit "" <$> ranges + in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) | otherwise = [] where relatedRanges indexedContent name = @@ -617,10 +622,10 @@ suggestDeleteUnusedBinding (L nLoc _name) | isTheBinding nLoc -> let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] - in - extendForSpaces indexedContent (toRange l) : - concatMap (findSig . reLoc) hsmodDecls - _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches + withSpaces = extendToIncludePreviousNewlineIfPossible indexedContent + (extendForHaddock indexedContent (toRange l)) + in withSpaces : concatMap (findSig . reLoc) hsmodDecls + _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpans _ _ _ = [] extractNameAndMatchesFromFunBind @@ -637,7 +642,9 @@ 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 $ extendToIncludePreviousNewlineIfPossible indexedContent + (extendForHaddock indexedContent (toRange l)) Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] @@ -700,7 +707,9 @@ suggestDeleteUnusedBinding then let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] - in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs + withHaddock = extendForHaddock indexedContent (toRange l) + withSpaces = extendForSpaces indexedContent withHaddock + in withSpaces : concatMap (findSig . reLoc) lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpanForHsBind _ _ _ _ = [] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index f367b393a0..ddfa8d599f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -7,14 +7,15 @@ module Development.IDE.Plugin.CodeAction.PositionIndexed , extendAllToIncludeCommaIfPossible , extendToIncludePreviousNewlineIfPossible , mergeRanges + , extendForHaddock ) where import Data.Char -import Data.List +import Data.List as List +import Data.Map as Map import Language.LSP.Protocol.Types (Position (Position), Range (Range, _end, _start)) - type PositionIndexed a = [(Position, a)] type PositionIndexedString = PositionIndexed Char @@ -67,16 +68,28 @@ stripRange r s = case unconsRange r s of -- Assumes input ranges are sorted on the start positions. mergeRanges :: [Range] -> [Range] mergeRanges (r : r' : rest) - | - -- r' is contained in r - _end r > _end r' = mergeRanges (r : rest) - | - -- r and r' are overlapping - _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) - - | otherwise = r : mergeRanges (r' : rest) + | _end r > _end r' = + mergeRanges (r : rest) + + | isAdjacent r r' = + mergeRanges (r { _end = _end r' } : rest) + + | otherwise = + r : mergeRanges (r' : rest) + mergeRanges other = other + +isAdjacent :: Range -> Range -> Bool +isAdjacent r r' = + let Position l1 c1 = _end r + Position l2 c2 = _start r' + in + -- Same line overlap + (l1 == l2 && c1 >= c2) + || + -- Direct next line (no blank line in between) + (l2 == l1 + 1 && c2 == 0) -- | Returns a sorted list of ranges with extended selections including preceding or trailing commas -- -- @ @@ -139,3 +152,97 @@ extendToIncludePreviousNewlineIfPossible indexedString range else case xs of (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) _ -> Just pos + +extendForHaddock :: PositionIndexedString -> Range -> Range +extendForHaddock indexedContent range = + let Position startLineUInt _ = _start range + startLine = fromIntegral startLineUInt :: Int + + lineMap :: Map Int String + lineMap = Map.fromListWith (++) + [ (lineNum, [ch]) + | (Position lineUInt _, ch) <- indexedContent + , let lineNum = fromIntegral lineUInt :: Int + ] + + getLine :: Int -> String + getLine i = + let raw = Map.findWithDefault "" i lineMap + in reverse raw + + + linesToConsume = countHaddockLines startLine getLine :: Int + + in if linesToConsume == 0 + then range + else + let newStart = Position (fromIntegral (startLine - linesToConsume)) 0 + in range { _start = newStart } + +countHaddockLines :: Int -> (Int -> String) -> Int +countHaddockLines sigLine getLine = + let prevLineIdx = sigLine - 1 + in if prevLineIdx < 0 + then 0 else + let stripped = (getLine prevLineIdx) + in if isBlankLine stripped + then 0 + + else if isHaddockBlockEnd stripped + then case scanBlockUp (prevLineIdx - 1) of + Just openerLine -> sigLine - openerLine + Nothing -> 0 + + else if isLineHaddock stripped + then sigLine - prevLineIdx + + else if isCommentLine stripped + then case scanLineCommentBlockUp (prevLineIdx - 1) of + Just haddockLine -> sigLine - haddockLine + Nothing -> 0 + + else 0 + where + scanBlockUp :: Int -> Maybe Int + scanBlockUp idx + | idx < 0 = Nothing + | otherwise = + let stripped = dropWhile isSpace (getLine idx) + in if isBlankLine stripped + then scanBlockUp (idx - 1) + else if isHaddockBlockStart stripped + then Just idx + else if isPlainBlockStart stripped + then Nothing + else scanBlockUp (idx - 1) + + scanLineCommentBlockUp :: Int -> Maybe Int + scanLineCommentBlockUp idx + | idx < 0 = Nothing + | otherwise = + let stripped = dropWhile isSpace (getLine idx) + in if isBlankLine stripped + then Nothing + else if isLineHaddock stripped + then Just idx + else if isCommentLine stripped + then scanLineCommentBlockUp (idx - 1) + else Nothing + +isHaddockBlockStart :: String -> Bool +isHaddockBlockStart s = "{- |" `isPrefixOf` s || "{-|" `isPrefixOf` s + +isPlainBlockStart :: String -> Bool +isPlainBlockStart s = "{-" `isPrefixOf` s && not (isHaddockBlockStart s) + +isHaddockBlockEnd :: String -> Bool +isHaddockBlockEnd s = "-}" `isPrefixOf` s + +isLineHaddock :: String -> Bool +isLineHaddock s = "-- |" `isPrefixOf` s || "--^" `isPrefixOf` s + +isCommentLine :: String -> Bool +isCommentLine s = "--" `isPrefixOf` s + +isBlankLine :: String -> Bool +isBlankLine = all isSpace From 9c6adc52972b01a737bf4aeb3dfff95bc056e0d4 Mon Sep 17 00:00:00 2001 From: vidit-od Date: Wed, 1 Apr 2026 17:06:37 +0530 Subject: [PATCH 2/2] Add tests for haddock deletion --- .../IDE/Plugin/CodeAction/PositionIndexed.hs | 8 +-- plugins/hls-refactor-plugin/test/Main.hs | 60 +++++++++++++++++++ 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index ddfa8d599f..b89cd0ff50 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -12,8 +12,8 @@ module Development.IDE.Plugin.CodeAction.PositionIndexed where import Data.Char -import Data.List as List -import Data.Map as Map +import Data.List as List +import Data.Map as Map import Language.LSP.Protocol.Types (Position (Position), Range (Range, _end, _start)) type PositionIndexed a = [(Position, a)] @@ -191,7 +191,7 @@ countHaddockLines sigLine getLine = else if isHaddockBlockEnd stripped then case scanBlockUp (prevLineIdx - 1) of Just openerLine -> sigLine - openerLine - Nothing -> 0 + Nothing -> 0 else if isLineHaddock stripped then sigLine - prevLineIdx @@ -199,7 +199,7 @@ countHaddockLines sigLine getLine = else if isCommentLine stripped then case scanLineCommentBlockUp (prevLineIdx - 1) of Just haddockLine -> sigLine - haddockLine - Nothing -> 0 + Nothing -> 0 else 0 where diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 8c73eab52e..63e84be23c 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -2616,6 +2616,66 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action" , "a = 3" , "b = 4" ] + , testSession "delete unused top level binding with single line haddock comment" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "-- | Haddock Comment 1" + , "-- Haddock Comment 2" + , "-- Haddock Comment 3" + , "f :: Int" + , "f = 42" + , "" + , "some = ()" + ] + (7, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] + , testSession "delete unused top level binding with block comment" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "{- | Haddock Comment 1" + , "Haddock Comment 2" + , "-}" + , "f :: Int" + , "f = 42" + , "" + , "some = ()" + ] + (7, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ] + , testSession "delete unused top level binding with plain line comment" $ + testFor + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "-- Line 1" + , "f :: Int" + , "f = 42" + , "" + , "some = ()" + ] + (5, 0) + "Delete ‘f’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "-- Line 1" + , "" + , "some = ()" + ] ] where testFor sourceLines pos@(l,c) expectedTitle expectedLines = do