Remove haddock

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 _ _ _ _ = []
 

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

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