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 091b99eb8b..19bdc9c358 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -118,6 +118,7 @@ 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 (..)) @@ -125,10 +126,12 @@ import GHC (AddEpAnn (Ad #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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 6ef6a9d219..e6230bfccb 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index eccd810c5b..17900f48bd 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/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 #-}"