Fix deleting unused bindings with Haddock docs V2

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

@@ -118,17 +118,20 @@ import           GHC                                               (AddEpAnn (Ad
 #if MIN_VERSION_ghc(9,9,0) && !MIN_VERSION_ghc(9,11,0)
 import           GHC                                               (AddEpAnn (AddEpAnn),
                                                                     AnnsModule (am_main),
+                                                                    EpAnnComments (..),
                                                                     EpaLocation,
                                                                     EpaLocation' (..),
                                                                     HasLoc (..))
 #endif
 
 #if MIN_VERSION_ghc(9,11,0)
 import           GHC                                               (AnnsModule (am_where),
+                                                                    EpAnnComments (..),
                                                                     EpToken (..),
                                                                     EpaLocation,
                                                                     EpaLocation' (..),
                                                                     HasLoc (..))
+import           GHC.Parser.Annotation                             (epaLocationRealSrcSpan)
 #endif
 
 
@@ -141,7 +144,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) =
   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
@@ -601,29 +604,30 @@ 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
+#if MIN_VERSION_ghc(9,9,0)
+      hsmodDeclsWithDocs = balanceCommentsList hsmodDecls
+#else
+      hsmodDeclsWithDocs = hsmodDecls -- comments are not deleted on GHC<9.10
+#endif
+      hsmodSigs = [L l sig | L l (SigD _ sig) <- hsmodDeclsWithDocs]
       relatedRanges indexedContent name =
-        concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls
+        concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDeclsWithDocs
       toRange = realSrcSpanToRange
       extendForSpaces = extendToIncludePreviousNewlineIfPossible
 
       findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]
-      findRelatedSpans
-        indexedContent
-        name
-        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =
-        case lname of
+      findRelatedSpans indexedContent name decl = case decl of
+        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches))))
+         -> 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) :
-              concatMap (findSig . reLoc) hsmodDecls
+            extendForSpaces indexedContent (toRange l)
+            : concatMap (findRelatedSigSpan' indexedContent name) hsmodSigs
           _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches
-      findRelatedSpans _ _ _ = []
+        _ -> []
 
       extractNameAndMatchesFromFunBind
         :: HsBind GhcPs
@@ -635,13 +639,23 @@ suggestDeleteUnusedBinding
           } = Just (reLoc lname, matches)
       extractNameAndMatchesFromFunBind _ = Nothing
 
-      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 (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused
-          _ -> []
+      -- | For given name, find the span of related type signature.
+      findRelatedSigSpan' :: PositionIndexedString -> String -> LSig GhcPs -> [Range]
+      findRelatedSigSpan' indexedContent name = \case
+#if MIN_VERSION_ghc(9,9,0)
+        (L (EpAnn sigSpan _ c) sig) ->
+          let l = epaLocationRealSrcSpan sigSpan
+          in case findRelatedSigSpan1 name sig of
+            -- On GHC 9.10+ this will include Haddock comments.
+            Just (_span, True) -> pure . extendForSpaces indexedContent . toRange $ l `withCommentSpan` c
+#else
+        (reLoc -> L (RealSrcSpan l _) sig) ->
+          case findRelatedSigSpan1 name sig of
+            Just (_span, True) -> pure . extendForSpaces indexedContent . toRange $ l
+#endif
+            Just (RealSrcSpan span _, False) -> pure $ toRange span
+            _ -> []
+        _ -> []
 
       -- Second of the tuple means there is only one match
       findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)
@@ -712,10 +726,8 @@ suggestDeleteUnusedBinding
         lsigs
         (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =
         if isTheBinding (getLoc lname)
-        then
-          let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig
-              findSig _ = []
-          in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs
+        then extendForSpaces indexedContent (toRange l)
+             : concatMap (findRelatedSigSpan' indexedContent name) lsigs
         else concatMap (findRelatedSpanForMatch indexedContent name) matches
       findRelatedSpanForHsBind _ _ _ _ = []
 
@@ -2126,3 +2138,28 @@ matchRegExMultipleImports message = do
                             _            -> Nothing
   imps <- regExImports imports
   return (binding, imps)
+
+#if MIN_VERSION_ghc(9,9,0)
+-- | Expand signature span to include Haddock.
+withCommentSpan :: RealSrcSpan -> EpAnnComments -> RealSrcSpan
+withCommentSpan idL = foldl' combineRealSrcSpans idL . map commsSrc . commsToList
+  where
+    commsSrc :: GenLocated (EpaLocation' a) e -> RealSrcSpan
+    commsSrc (L l _) = epaLocationRealSrcSpan l
+    commsToList :: EpAnnComments -> [LEpaComment]
+    commsToList = \case
+      EpaComments prior -> prior
+      EpaCommentsBalanced prior following -> prior <> following
+#endif
+
+#if MIN_VERSION_ghc(9,9,0) && !MIN_VERSION_ghc(9,11,0)
+-- | Used in the parser only, extract the 'RealSrcSpan' from an
+-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
+-- partial function is safe.
+--
+-- GHC compatibility note:
+-- EpaLocation' exists since 9.10, but this function was updated in 9.12
+epaLocationRealSrcSpan :: EpaLocation' a -> RealSrcSpan
+epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
+epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
+#endif

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

@@ -13,7 +13,10 @@ module Development.IDE.Plugin.CodeAction.ExactPrint (
   hideSymbol,
   liftParseAST,
 
-  wildCardSymbol
+  wildCardSymbol,
+
+  -- * Re-exports
+  balanceCommentsList,
 ) where
 
 import           Control.Monad

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

@@ -2533,6 +2533,67 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action"
       , ""
       , "some = ()"
       ]
+  , knownBrokenForGhcVersions [GHC96, GHC98] "Not implemented for GHC <9.10 (AST changed)" $
+    testSession "delete unused leading top level binding with Haddock comment" $
+    testFor
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "-- | line docs for foo"
+      , "foo :: Int"
+      , "foo = 1"
+      , ""
+      , "some = ()"
+      ]
+      (5, 0)
+      1
+      "Delete ‘foo’"
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "some = ()"
+      ]
+  , knownBrokenForGhcVersions [GHC96, GHC98] "Not implemented for GHC <9.10 (AST changed)" $
+    testSession "delete unused trailing top level binding with Haddock comment" $
+    testFor
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "oof = 1"
+      , "oof :: Int"
+      , "-- ^ trailing docs for oof"
+      , ""
+      , "some = ()"
+      ]
+      (3, 0)
+      1
+      "Delete ‘oof’"
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "some = ()"
+      ]
+  , knownBrokenForGhcVersions [GHC96, GHC98] "Not implemented for GHC <9.10 (AST changed)" $
+    testSession "delete unused top level binding with block Haddock comment" $
+    testFor
+      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+      , "module A (some) where"
+      , ""
+      , "{-| block 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 #-}"