Fix deleting unused bindings with Haddock docs V2

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -75,7 +75,7 @@
 import           Development.IDE.Types.Options
 import           GHC                                               (DeltaPos (..),
                                                                     EpAnn (..),
-                                                                    LEpaComment)
+                                                                    LEpaComment, EpAnnComments (..), realSrcSpan)
 import           GHC.Iface.Ext.Types                               (ContextInfo (..),
                                                                     IdentifierDetails (..))
 import qualified GHC.LanguageExtensions                            as Lang
@@ -128,6 +128,7 @@
                                                                     EpaLocation,
                                                                     EpaLocation' (..),
                                                                     HasLoc (..))
+import GHC.Types.SrcLoc (combineSrcSpans)
 #endif
 
 
@@ -140,7 +141,7 @@
   liftIO $ do
     let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
     allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state
-    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile
+    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModuleWithComments `traverse` mbFile
     let
       textContents = fmap Rope.toText contents
       actions = caRemoveRedundantImports parsedModule textContents allDiags range uri
@@ -600,29 +601,29 @@
 -- 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
+        concatMap (findRelatedSpans indexedContent name) hsmodDecls
       toRange = realSrcSpanToRange
-      extendForSpaces = extendToIncludePreviousNewlineIfPossible
+      extendForDeletion indexedContent = extendToIncludePreviousNewlineIfPossible indexedContent
 
-      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]
-      findRelatedSpans
-        indexedContent
-        name
-        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =
-        case lname of
+      findRelatedSpans :: PositionIndexedString -> String -> LHsDecl GhcPs -> [Range]
+      findRelatedSpans indexedContent name decl = case decl of
+        (L (EpAnn (EpaSpan (RealSrcSpan l _)) _ c) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches))))
+         -> c `seq` decl `seq` case lname of
           (L nLoc _name) | isTheBinding nLoc ->
             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 _ _ _ = []
+        (L (EpAnn (EpaSpan (RealSrcSpan lname _)) _ c) (SigD _ bind))
+          -> [extendForDeletion indexedContent $ bind `seq` toRange $ joinComms (commsToList c) lname]
+        _ -> decl `seq` []
 
       extractNameAndMatchesFromFunBind
         :: HsBind GhcPs
@@ -634,11 +635,26 @@
           } = Just (reLoc lname, matches)
       extractNameAndMatchesFromFunBind _ = Nothing
 
+      joinComms :: [LEpaComment] -> RealSrcSpan -> RealSrcSpan
+      joinComms comms idL =
+        let locL (L l _) = l
+            epaL = \case
+              EpaSpan l -> l
+              EpaDelta l _ _ -> l
+            commsSrc = realSrcSpan . epaL . locL <$> comms
+        in foldl' combineRealSrcSpans idL commsSrc
+
+      commsToList :: EpAnnComments -> [LEpaComment]
+      commsToList = \case
+        EpaComments prior -> prior
+        EpaCommentsBalanced prior following -> prior <> following
+
+
       findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]
       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
           _ -> []
 
@@ -701,7 +717,7 @@
         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 _ _ _ _ = []
 

plugins/hls-refactor-plugin/test/Main.hs

@@ -2533,6 +2533,45 @@ 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)
+      1
+      "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)
+      1
+      "Delete ‘f’"
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "some = ()"
+      ]
   , testSession "delete unused binding in where clause" $
     testFor
       [ "{-# OPTIONS_GHC -Wunused-binds #-}"