From a76b094cca7bb8a23328d31b4fdb781716777a41 Mon Sep 17 00:00:00 2001 From: vidit-od Date: Tue, 24 Feb 2026 13:01:16 +0530 Subject: [PATCH 1/3] Migrate Refactor plugin --- .../src/Development/IDE/GHC/Compat/Error.hs | 1 + .../src/Development/IDE/Types/Diagnostics.hs | 1 - .../src/Development/IDE/Plugin/CodeAction.hs | 326 ++++++++++-------- .../IDE/Plugin/Plugins/AddArgument.hs | 20 +- .../IDE/Plugin/Plugins/Diagnostic.hs | 102 ++++-- .../IDE/Plugin/Plugins/FillHole.hs | 148 +++++++- .../IDE/Plugin/Plugins/FillTypeWildcard.hs | 44 +-- 7 files changed, 401 insertions(+), 241 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index 63ec75bfc9..20c4649f38 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Error.hs @@ -29,6 +29,7 @@ module Development.IDE.GHC.Compat.Error ( _GhcDriverMessage, _ReportHoleError, _TcRnIllegalWildcardInType, + _TcRnNotInScope, _TcRnPartialTypeSignatures, _TcRnMissingSignature, _TcRnSolverReport, diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 5072fa7ffa..d91a12ddad 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -29,7 +29,6 @@ module Development.IDE.Types.Diagnostics ( attachReason, attachedReason) where -import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Lens import qualified Data.Aeson as JSON 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 9f57bb185a..f53d7c5b76 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -22,6 +22,7 @@ import Control.Arrow (second, (&&&), (>>>)) import Control.Concurrent.STM.Stats (atomically) +import Control.Lens ((^?)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT (ExceptT)) @@ -49,6 +50,13 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat hiding (ImplicitPrelude) +import Development.IDE.GHC.Compat.Error (TcRnMessage (..), + _TcRnMessage, + msgEnvelopeErrorL) +import GHC.Tc.Errors.Types (ShadowedNameProvenance (..), + UnusedImportName (..), + UnusedImportReason (..), + UnusedNameProv (..)) #if !MIN_VERSION_ghc(9,11,0) import Development.IDE.GHC.Compat.Util #endif @@ -138,7 +146,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri liftIO $ do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri - allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state + allDiags <- atomically $ filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let textContents = fmap Rope.toText contents @@ -376,37 +384,44 @@ findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) -- imported from ‘Data.ByteString’ at B.hs:6:1-22 -- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 -- imported from ‘Data.Text’ at B.hs:7:1-16 -suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] -suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} - | Just [identifier, modName, s] <- - matchRegexUnifySpaces - _message - "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = - suggests identifier modName s - | Just [identifier] <- - matchRegexUnifySpaces - _message - "This binding for ‘([^`]+)’ shadows the existing bindings", - Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", - mods <- [(modName, s) | [_, modName, s] <- matched], - result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), - hideAll <- ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result) = - result <> [hideAll] - | otherwise = [] - where - L _ HsModule {hsmodImports} = ps - - suggests identifier modName s - | Just tcM <- mTcM, - Just har <- mHar, - [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), - mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, - title <- "Hide " <> identifier <> " from " <> modName = - if modName == "Prelude" && null mDecl - then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents - else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl - | otherwise = [] +suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> FileDiagnostic -> [(T.Text, [Either TextEdit Rewrite])] +suggestHideShadow ps fileContents mTcM mHar fd = + case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of + Just (TcRnShadowedName occName prov) -> + let identifier = T.pack $ occNameString occName + L _ HsModule{hsmodImports} = ps + + greModsAndSpans :: GlobalRdrElt -> [(T.Text, RealSrcSpan)] + greModsAndSpans gre = + [ (T.pack $ moduleNameString $ moduleName $ is_mod (is_decl imp), sp) + | imp <- gre_imp gre + , RealSrcSpan sp _ <- [is_dloc (is_decl imp)] + ] + + suggests :: T.Text -> RealSrcSpan -> [(T.Text, [Either TextEdit Rewrite])] + suggests modName s' + | Just tcM <- mTcM, + Just har <- mHar, + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents + else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] + + in case prov of + ShadowedNameProvenanceLocal _ -> [] + ShadowedNameProvenanceGlobal gres -> + let mods = nubOrdBy (compare `on` fst) + [ (modName, sp) + | gre <- gres + , (modName, sp) <- greModsAndSpans gre + ] + result = mods >>= uncurry suggests + hideAll = ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result) + in result <> [hideAll | length result > 1] + _ -> [] findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) findImportDeclByModuleName decls modName = flip find decls $ \case @@ -447,33 +462,46 @@ isUnusedImportedId maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs | otherwise = False -suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} --- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant - | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports - , Just c <- contents - , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings >>= trySplitIntoOriginalAndRecordField) - , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) - , not (null ranges') - = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] - --- File.hs:16:1: warning: --- The import of `Data.List' is redundant --- except perhaps to import instances from `Data.List' --- To import instances alone, use: import Data.List() - | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) - = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] - | otherwise = [] - where - -- In case of an unused record field import, the binding from the message will not match any import directly - -- In this case, we try if we can additionally extract a record field name - -- Example: The import of ‘B(b2)’ from module ‘ModuleB’ is redundant - trySplitIntoOriginalAndRecordField :: T.Text -> [T.Text] - trySplitIntoOriginalAndRecordField binding = - case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of - Just [_, fields] -> [binding, fields] - _ -> [binding] +suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents fd = + case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of + Just (TcRnUnusedImport impDecl reason) -> + let wantedModule = moduleNameString $ unLoc $ ideclName impDecl + mMatchedDecl = find (\(L _ d) -> moduleNameString (unLoc (ideclName d)) == wantedModule) hsmodImports + in case reason of + UnusedImportNone -> + case mMatchedDecl of + Just (L (locA -> l) _) + | Just r <- srcSpanToRange l + -> [("Remove import", [TextEdit (extendToWholeLineIfPossible contents r) ""])] + _ -> [] + UnusedImportSome unusedNames -> + case mMatchedDecl of + Just (L _ matchedDecl) -> + let titleBindings = map unusedImportNameText unusedNames + rangeBindings = map fieldOnlyName unusedNames + bindings = T.intercalate ", " titleBindings + ranges = concatMap (rangesForBindingImport matchedDecl . T.unpack) rangeBindings + + in case contents of + Just c -> + let ranges' = extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) ranges + in ([("Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges']) | not (null ranges')]) + Nothing -> [] + _ -> [] + _ -> [] + +fieldOnlyName :: UnusedImportName -> T.Text +fieldOnlyName (UnusedImportNameRegular name) = T.pack (getOccString name) +fieldOnlyName (UnusedImportNameRecField _ occName) = T.pack (occNameString occName) + +-- | Extract the text name from an UnusedImportName +unusedImportNameText :: UnusedImportName -> T.Text +unusedImportNameText (UnusedImportNameRegular name) = T.pack (getOccString name) +unusedImportNameText (UnusedImportNameRecField parent occName) = + case parent of + ParentIs name -> T.pack (getOccString name) <> "(" <> T.pack (occNameString occName) <> ")" + NoParent -> T.pack (occNameString occName) -- Fallback safety (unlikely) diagInRange :: Diagnostic -> Range -> Bool diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange @@ -488,10 +516,10 @@ diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange -- is likely to be removed and less likely the warning will be disabled. -- Therefore actions to remove a single or all redundant imports should be -- preferred, so that the client can prioritize them higher. -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents allDiags contextRange uri | Just pm <- m, - r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags, + r <- join $ map (\fd -> let d = fdLspDiagnostic fd in repeat d `zip` suggestRemoveRedundantImport pm contents fd) allDiags, allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], caRemoveAll <- removeAll allEdits, ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange], @@ -518,7 +546,7 @@ caRemoveRedundantImports m contents allDiags contextRange uri _data_ = Nothing _changeAnnotations = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction] +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents allDiags contextRange uri | Just pm <- m, Just txt <- contents, @@ -536,9 +564,9 @@ caRemoveInvalidExports m contents allDiags contextRange uri where extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges - groupDiag pm dig - | Just (title, ranges) <- suggestRemoveRedundantExport pm dig - = Just (title, dig, ranges) + groupDiag pm fd + | Just (title, ranges) <- suggestRemoveRedundantExport pm (fdLspDiagnostic fd) + = Just (title, fdLspDiagnostic fd, ranges) | otherwise = Nothing removeSingle (_, _, []) = Nothing @@ -591,14 +619,22 @@ suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} D ranges -> (txt, ranges) suggestRemoveRedundantExport _ _ = Nothing -suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestDeleteUnusedBinding - ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} - contents - 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 +suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBinding pm contents fd = + case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of + Just (TcRnUnusedName occName prov) + | isLocalUnusedName prov -> suggestDeleteUnusedBindingByName pm contents (T.pack $ occNameString occName) (fdLspDiagnostic fd) + _ -> [] + +isLocalUnusedName :: UnusedNameProv -> Bool +isLocalUnusedName UnusedNameTopDecl = True +isLocalUnusedName UnusedNameLocalBind = True +isLocalUnusedName UnusedNameMatch = True +isLocalUnusedName _ = False + +suggestDeleteUnusedBindingByName :: ParsedModule -> Maybe T.Text -> T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBindingByName ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} contents name Diagnostic{_range=_range} + | Just indexedContent <- indexedByPosition . T.unpack <$> contents = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) | otherwise = [] @@ -716,16 +752,19 @@ data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll getLocatedRange :: HasSrcSpan a => a -> Maybe Range getLocatedRange = srcSpanToRange . getLoc -suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit) -suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} +suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBinding srcOpt pm fd = -- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ -- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ -- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ + case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of + Just (TcRnUnusedName occName UnusedNameTopDecl) -> + suggestExportUnusedTopBindingByName srcOpt pm (T.pack $ occNameString occName) (fdLspDiagnostic fd) + _ -> Nothing + +suggestExportUnusedTopBindingByName :: Maybe T.Text -> ParsedModule -> T.Text -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBindingByName srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} name Diagnostic{..} | Just source <- srcOpt - , Just [_, name] <- - matchRegexUnifySpaces - _message - ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’" , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) . mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing) @@ -909,16 +948,22 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range,..} = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] | otherwise = [] -suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range} - | Just (name, typ) <- matchVariableNotInScope message = +suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestNewDefinition ideOptions parsedModule contents fd + | Just (name, typ) <- matchVariableNotInScope fd = newDefinitionAction ideOptions parsedModule _range name typ - | Just (name, typ) <- matchFoundHole message, - [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name (Just typ) = - [(label, mkRenameEdit contents _range name : newDefinitionEdits)] + | Just (name, typ) <- matchFoundHole fd + , let definedName = fromMaybe name (T.stripPrefix "_" name) + , let typ' = case T.stripPrefix "_" name of + Nothing | isPlainTyVar typ -> Nothing + _ -> Just typ + , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ' = + [(label, mkRenameEdit contents _range definedName : newDefinitionEdits)] | otherwise = [] where - message = unifySpaces _message + Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic + -- A "plain type variable" is a single lowercase word like p, a etc + isPlainTyVar t = T.all (\c -> isAlphaNum c || c == '_') t && not (T.null t) && isLower (T.head t) newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])] newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ @@ -929,13 +974,17 @@ newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ ], nextLineP <- Position {_line = _line lastLineP + 1, _character = 0} = [ ( "Define " <> sig, - [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])] + [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, definedName <> " = _"])] ) ] | otherwise = [] where colon = if optNewColonConvention then " : " else " :: " - sig = name <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ) + definedName = + case T.stripPrefix "_" name of + Just n -> n + Nothing -> name + sig = definedName <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ) ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule {- Handles two variants with different formatting @@ -1364,74 +1413,45 @@ suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing <> "` to the context of the type signature for `" <> typeSignatureName <> "`" -- | Suggests the removal of a redundant constraint for a type signature. -removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraints :: DynFlags -> ParsedSource -> FileDiagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraints df ps fd = + case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of + Just (TcRnRedundantConstraints ids _) -> removeRedundantConstraintsStructured df ps ids (fdLspDiagnostic fd) + _ -> [] + +removeRedundantConstraintsStructured :: DynFlags -> ParsedSource -> [Id] -> Diagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraintsStructured df ps ids _diag@Diagnostic{..} = + let #if MIN_VERSION_ghc(9,9,0) -removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} + L _ HsModule {hsmodDecls} = ps #else -removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..} + L _ HsModule {hsmodDecls} = makeDeltaAst ps #endif --- • Redundant constraint: Eq a --- • In the type signature for: --- foo :: forall a. Eq a => a -> a --- • Redundant constraints: (Monoid a, Show a) --- • In the type signature for: --- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool - -- Account for both "Redundant constraint" and "Redundant constraints". - | "Redundant constraint" `T.isInfixOf` _message - , Just typeSignatureName <- findTypeSignatureName _message - , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) - <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls - , Just redundantConstraintList <- findRedundantConstraints _message - , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig - = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] - | otherwise = [] - where - toRemove df list a = T.pack (showSDoc df (ppr a)) `elem` list - - parseConstraints :: T.Text -> [T.Text] - parseConstraints t = t - & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") - <&> T.strip - - stripConstraintsParens :: T.Text -> T.Text - stripConstraintsParens constraints = - if "(" `T.isPrefixOf` constraints - then constraints & T.drop 1 & T.dropEnd 1 & T.strip - else constraints - -{- -9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning: - ⢠Redundant constraints: (Eq a, Show a) - ⢠In the type signature for: - foo :: forall a. (Eq a, Show a) => a -> Bool", - -9.0: "message": "⢠Redundant constraints: (Eq a, Show a) - ⢠In the type signature for: - foo :: forall a. (Eq a, Show a) => a -> Bool", --} - findRedundantConstraints :: T.Text -> Maybe [T.Text] - findRedundantConstraints t = t - & T.lines - -- In <9.2 it's the first line, in 9.2 it' the second line - & take 2 - & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) - & listToMaybe - >>= listToMaybe - <&> parseConstraints - - formatConstraints :: [T.Text] -> T.Text - formatConstraints [] = "" - formatConstraints [constraint] = constraint - formatConstraints constraintList = constraintList - & T.intercalate ", " - & \cs -> "(" <> cs <> ")" - - actionTitle :: [T.Text] -> T.Text -> T.Text - actionTitle constraintList typeSignatureName = - "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" - <> formatConstraints constraintList - <> "` from the context of the type signature for `" <> typeSignatureName <> "`" - + in + case () of + _ | not (null ids) + , Just typeSignatureName <- findTypeSignatureName _message + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) + <- fmap (traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls + , redundantConstraintList <- map (T.pack . showSDoc df . ppr . varType) ids + , rewrite <- removeConstraint (toRemove redundantConstraintList) sig + -> [(actionTitle redundantConstraintList typeSignatureName, rewrite)] + | otherwise -> [] + where + toRemove list a = T.pack (showSDoc df (ppr a)) `elem` list + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + actionTitle :: [T.Text] -> T.Text -> T.Text + actionTitle constraintList typeSignatureName = + "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" + <> formatConstraints constraintList + <> "` from the context of the type signature for `" <> typeSignatureName <> "`" ------------------------------------------------------------------------------------------------- suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index e316dc005e..92879fa412 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -32,6 +32,7 @@ import GHC.Parser.Annotation (TokenLocation (..)) #if !MIN_VERSION_ghc(9,9,0) import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst) import Development.IDE.GHC.ExactPrint (genAnchor1) +import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic)) import GHC.Parser.Annotation (EpAnn (..), SrcSpanAnn' (..), emptyComments) @@ -66,13 +67,13 @@ type HsArrow pass = HsMultAnn pass -- foo :: a -> b -> c -> d -- foo a b = \c -> ... -- In this case a new argument would have to add its type between b and c in the signature. -plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])] -plugin parsedModule Diagnostic {_message, _range} - | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ - | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ) +plugin :: ParsedModule -> FileDiagnostic -> Either PluginError [(T.Text, [TextEdit])] +plugin parsedModule fd + | Just (name, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range name typ + | Just (name, typ) <- matchFoundHoleIncludeUnderscore fd = addArgumentAction parsedModule _range name (Just typ) | otherwise = pure [] where - message = unifySpaces _message + Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic -- Given a name for the new binding, add a new pattern to the match in the last position, -- returning how many patterns there were in this match prior to the transformation: @@ -155,11 +156,14 @@ addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' Nothing -> pure moduleSrc' let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource) - pure [("Add argument ‘" <> name <> "’ to function", diff)] + pure [("Add argument ‘" <> definedName <> "’ to function", diff)] where addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg - addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name - + addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches definedName + definedName = + case T.stripPrefix "_" name of + Just n -> n + Nothing -> name spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range) -- Transform an LHsType into a list of arguments and return type, to make transformations easier. diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs index 7facc8f54c..8876675355 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs @@ -1,15 +1,31 @@ +{-# LANGUAGE CPP #-} + module Development.IDE.Plugin.Plugins.Diagnostic ( matchVariableNotInScope, matchRegexUnifySpaces, unifySpaces, matchFoundHole, matchFoundHoleIncludeUnderscore, + diagReportHoleError ) where -import Data.Bifunctor (Bifunctor (..)) -import qualified Data.Text as T -import Text.Regex.TDFA ((=~~)) +import Control.Lens +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Text as T +import Development.IDE (printOutputable) +import Development.IDE.GHC.Compat (RdrName) +import Development.IDE.GHC.Compat.Error (Hole, _ReportHoleError, + _TcRnMessage, + _TcRnNotInScope, + _TcRnSolverReport, hole_occ, + hole_ty, msgEnvelopeErrorL, + reportContentL) +import Development.IDE.Types.Diagnostics (FileDiagnostic, + _SomeStructuredMessage, + fdStructuredMessageL) +import GHC.Tc.Errors.Types (NotInScopeError) +import Text.Regex.TDFA ((=~~)) unifySpaces :: T.Text -> T.Text unifySpaces = T.unwords . T.words @@ -27,33 +43,53 @@ matchRegex message regex = case message =~~ regex of matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] matchRegexUnifySpaces message = matchRegex (unifySpaces message) -matchFoundHole :: T.Text -> Maybe (T.Text, T.Text) -matchFoundHole message - | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" = - Just (name, typ) - | otherwise = Nothing - -matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text) -matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message - -matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text) -matchVariableNotInScope message - -- * Variable not in scope: - -- suggestAcion :: Maybe T.Text -> Range -> Range - -- * Variable not in scope: - -- suggestAcion - | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ) - | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing) - | otherwise = Nothing - where - matchVariableNotInScopeTyped message - | Just [name, typ0] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" - , -- When some name in scope is similar to not-in-scope variable, the type is followed by - -- "Suggested fix: Perhaps use ..." - typ:_ <- T.splitOn " Suggested fix:" typ0 = - Just (name, typ) - | otherwise = Nothing - matchVariableNotInScopeUntyped message - | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" = - Just name - | otherwise = Nothing +matchFoundHole :: FileDiagnostic -> Maybe (T.Text, T.Text) +matchFoundHole fd = do + hole <- diagReportHoleError fd + Just (printOutputable (hole_occ hole), printOutputable (hole_ty hole)) + +matchFoundHoleIncludeUnderscore :: FileDiagnostic -> Maybe (T.Text, T.Text) +matchFoundHoleIncludeUnderscore fd = first ("_" <>) <$> matchFoundHole fd + +matchVariableNotInScope :: FileDiagnostic -> Maybe (T.Text, Maybe T.Text) +matchVariableNotInScope fd = do + (rdrName, _) <- diagReportNotInScope fd + Just (printOutputable rdrName, Nothing) + +-- | Extract the 'Hole' out of a 'FileDiagnostic' +diagReportHoleError :: FileDiagnostic -> Maybe Hole +diagReportHoleError diag = do + solverReport <- + diag + ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessage + . _TcRnSolverReport + . _1 + (hole, _) <- solverReport ^? reportContentL . _ReportHoleError + + Just hole + +-- | Extract the 'NotInScopeError' and the corresponding 'RdrName' from a 'FileDiagnostic' +-- if it represents a not-in-scope error. +diagReportNotInScope :: FileDiagnostic -> Maybe (RdrName, NotInScopeError) +diagReportNotInScope diag = do +#if MIN_VERSION_ghc(9,13,0) + (err, rdrName) <- + diag + ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessage + . _TcRnNotInScope +#else + (err, rdrName, _, _) <- + diag + ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessage + . _TcRnNotInScope +#endif + Just (rdrName, err) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs index eb6172c7fa..e256e4023f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -2,42 +2,156 @@ module Development.IDE.Plugin.Plugins.FillHole ( suggestFillHole ) where +import Control.Lens ((^.), (^?)) import Control.Monad (guard) import Data.Char +import qualified Data.HashSet as Set import qualified Data.Text as T -import Development.IDE.Plugin.Plugins.Diagnostic -import Language.LSP.Protocol.Types (Diagnostic (..), - TextEdit (TextEdit)) +import Development.IDE (FileDiagnostic, + fdLspDiagnosticL, + printOutputable) +import Development.IDE.GHC.Compat (ParsedModule, SDoc, + defaultSDocContext, + hsmodImports, + ideclAs, ideclName, + ideclQualified, + lookupOccEnv, + moduleNameString, + pm_parsed_source, + renderWithContext, + unLoc) +import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (TcRnMessageDetailed), + _TcRnMessageWithCtx, + _TcRnMessageWithInfo, + hole_occ, + msgEnvelopeErrorL) +import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage, + fdStructuredMessageL) +import Development.IDE.Types.Exports (ExportsMap (..), + mkVarOrDataOcc, + moduleNameText) +import GHC.Tc.Errors.Types (ErrInfo (ErrInfo)) +import Ide.PluginUtils (unescape) +import Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..)) +import Language.LSP.Protocol.Lens (HasRange (..)) +import Language.LSP.Protocol.Types (TextEdit (TextEdit)) import Text.Regex.TDFA (MatchResult (..), (=~)) -suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] -suggestFillHole Diagnostic{_range=_range,..} - | Just holeName <- extractHoleName _message - , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = - let isInfixHole = _message =~ addBackticks holeName :: Bool in +suggestFillHole :: ExportsMap -> ParsedModule -> FileDiagnostic -> [(T.Text, TextEdit)] +suggestFillHole exportsMap pm diag + | Just holeName <- extractHoleName diag + , Just (ErrInfo ctx suppl) <- extractErrInfo diag + , (holeFits, refFits) <- processHoleSuggestions $ T.lines (printErr suppl) = + let isInfixHole = printErr ctx =~ addBackticks holeName :: Bool in map (proposeHoleFit holeName False isInfixHole) holeFits ++ map (proposeHoleFit holeName True isInfixHole) refFits | otherwise = [] where - extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + qualify = qualifyFit exportsMap pm + + extractHoleName :: FileDiagnostic -> Maybe T.Text + extractHoleName d = do + hole <- diagReportHoleError d + Just $ printOutputable (hole_occ hole) + + extractErrInfo :: FileDiagnostic -> Maybe ErrInfo + extractErrInfo d = do + (_, TcRnMessageDetailed errInfo _) <- + d ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessageWithCtx + . _TcRnMessageWithInfo + Just errInfo + + printErr :: SDoc -> T.Text + printErr = unescape . T.pack . renderWithContext defaultSDocContext + + addBackticks :: T.Text -> T.Text addBackticks text = "`" <> text <> "`" + + addParens :: T.Text -> T.Text addParens text = "(" <> text <> ")" + + proposeHoleFit :: T.Text -> Bool -> Bool -> T.Text -> (T.Text, TextEdit) proposeHoleFit holeName parenthise isInfixHole name = case T.uncons name of Nothing -> error "impossible: empty name provided by ghc" Just (firstChr, _) -> - let isInfixOperator = firstChr == '(' - name' = getOperatorNotation isInfixHole isInfixOperator name in - ( "Replace " <> holeName <> " with " <> name - , TextEdit _range (if parenthise then addParens name' else name') - ) + let cleanName = qualify (stripUnique name) + isInfixOperator = firstChr == '(' + name' = getOperatorNotation isInfixHole isInfixOperator cleanName + replacement = if parenthise then addParens name' else name' + in + ( "Replace " <> holeName <> " with " <> cleanName + , TextEdit (diag ^. fdLspDiagnosticL . range) replacement + ) + + getOperatorNotation :: Bool -> Bool -> T.Text -> T.Text getOperatorNotation True False name = addBackticks name getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) getOperatorNotation _isInfixHole _isInfixOperator name = name - headOrThrow msg = \case - [] -> error msg - (x:_) -> x + + stripUnique :: T.Text -> T.Text + stripUnique t = + case T.breakOnEnd "_" t of + (prefix, suffix) + | T.null prefix -> t + | T.null suffix -> t + | not (T.all isAlphaNum suffix) -> t + | otherwise -> T.dropEnd (T.length suffix + 1) t + +-- | Given the exports map, parsed module (for its imports), and a hole fit +-- name like "toException", return the qualified version like "E.toException" +-- if a qualifying import exists, otherwise return the name as it is. +qualifyFit :: ExportsMap -> ParsedModule -> T.Text -> T.Text +qualifyFit exportsMap pm fitName = + case findQualifier of + Nothing -> fitName + Just qualifier -> qualifier <> "." <> fitName + where + -- All modules that export this name + exportingModules :: [T.Text] + exportingModules = + let occ = mkVarOrDataOcc fitName + identSet = lookupOccEnv (getExportsMap exportsMap) occ + idents = maybe [] Set.toList identSet + in map moduleNameText idents + + -- All qualified imports from this file: (moduleName, qualifier) + qualifiedImports :: [(T.Text, T.Text)] + qualifiedImports = + let imports = hsmodImports . unLoc . pm_parsed_source $ pm + in [ (modName decl, qualifier decl) + | i <- imports + , let decl = unLoc i + , isQualified decl + ] + + isQualified decl = ideclQualified decl `elem` [QualifiedPre, QualifiedPost] + + modName decl = + T.pack . moduleNameString . unLoc . ideclName $ decl + + qualifier decl = + case ideclAs decl of + Just alias -> T.pack . moduleNameString . unLoc $ alias + Nothing -> modName decl + + -- Find first qualified import whose module is in the exporting modules list + findQualifier :: Maybe T.Text + findQualifier = + let exportingSet = exportingModules + in fmap snd + . safeHead + . filter (\(modN, _) -> modN `elem` exportingSet) + $ qualifiedImports + + safeHead [] = Nothing + safeHead (x:_) = Just x + processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) processHoleSuggestions mm = (holeSuggestions, refSuggestions) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs index 43a0c246cc..4049a9d6f7 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs @@ -4,20 +4,21 @@ module Development.IDE.Plugin.Plugins.FillTypeWildcard ) where import Control.Lens -import Data.Maybe (isJust) -import qualified Data.Text as T -import Development.IDE (FileDiagnostic (..), - fdStructuredMessageL, - printOutputable) -import Development.IDE.GHC.Compat hiding (vcat) +import Data.Maybe (isJust) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic (..), + fdStructuredMessageL, + printOutputable) +import Development.IDE.GHC.Compat hiding (vcat) import Development.IDE.GHC.Compat.Error -import Development.IDE.Types.Diagnostics (_SomeStructuredMessage) -import GHC.Tc.Errors.Types (ErrInfo (..)) -import Language.LSP.Protocol.Types (Diagnostic (..), - TextEdit (TextEdit)) +import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage) +import GHC.Tc.Errors.Types (ErrInfo (..)) +import Language.LSP.Protocol.Types (Diagnostic (..), + TextEdit (TextEdit)) #if MIN_VERSION_ghc(9,13,0) -import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) -import GHC.Utils.Outputable (vcat) +import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) +import GHC.Utils.Outputable (vcat) #endif suggestFillTypeWildcard :: FileDiagnostic -> [(T.Text, TextEdit)] @@ -33,21 +34,6 @@ isWildcardDiagnostic :: FileDiagnostic -> Bool isWildcardDiagnostic = maybe False (isJust . (^? _TypeHole) . hole_sort) . diagReportHoleError --- | Extract the 'Hole' out of a 'FileDiagnostic' -diagReportHoleError :: FileDiagnostic -> Maybe Hole -diagReportHoleError diag = do - solverReport <- - diag - ^? fdStructuredMessageL - . _SomeStructuredMessage - . msgEnvelopeErrorL - . _TcRnMessage - . _TcRnSolverReport - . _1 - (hole, _) <- solverReport ^? reportContentL . _ReportHoleError - - Just hole - -- | Extract the type and surround it in parentheses except in obviously safe cases. -- -- Inferring when parentheses are actually needed around the type signature would @@ -89,10 +75,10 @@ diagErrInfoContext diag = do . _TcRnMessageWithInfo let TcRnMessageDetailed err _ = detailedMsg #if MIN_VERSION_ghc(9,13,0) - ErrInfo errInfoCtx _ _ = err + let ErrInfo errInfoCtx _ _ = err Just (printOutputable (vcat $ map pprErrCtxtMsg errInfoCtx)) #else - ErrInfo errInfoCtx _ = err + let ErrInfo errInfoCtx _ = err Just (printOutputable errInfoCtx) #endif From b89cbb69dbf227bae5e123c25d1a6e1c8b9624eb Mon Sep 17 00:00:00 2001 From: vidit-od Date: Wed, 25 Feb 2026 15:21:50 +0530 Subject: [PATCH 2/3] Fix builds and Regex diagnostics for 9.6 --- .../src/Development/IDE/Plugin/CodeAction.hs | 121 ++++++++++++++---- .../IDE/Plugin/Plugins/AddArgument.hs | 2 +- .../IDE/Plugin/Plugins/FillHole.hs | 25 ++-- 3 files changed, 114 insertions(+), 34 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 f53d7c5b76..d6de916a21 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -53,10 +53,7 @@ import Development.IDE.GHC.Compat hiding import Development.IDE.GHC.Compat.Error (TcRnMessage (..), _TcRnMessage, msgEnvelopeErrorL) -import GHC.Tc.Errors.Types (ShadowedNameProvenance (..), - UnusedImportName (..), - UnusedImportReason (..), - UnusedNameProv (..)) +import GHC.Tc.Errors.Types (ShadowedNameProvenance (..)) #if !MIN_VERSION_ghc(9,11,0) import Development.IDE.GHC.Compat.Util #endif @@ -136,7 +133,11 @@ import GHC (AnnsModule ( EpaLocation' (..), HasLoc (..)) #endif - +#if MIN_VERSION_ghc(9,7,0) +import GHC.Tc.Errors.Types (UnusedImportName (..), + UnusedImportReason (..), + UnusedNameProv (..)) +#endif ------------------------------------------------------------------------------------------------- @@ -393,10 +394,16 @@ suggestHideShadow ps fileContents mTcM mHar fd = greModsAndSpans :: GlobalRdrElt -> [(T.Text, RealSrcSpan)] greModsAndSpans gre = - [ (T.pack $ moduleNameString $ moduleName $ is_mod (is_decl imp), sp) - | imp <- gre_imp gre - , RealSrcSpan sp _ <- [is_dloc (is_decl imp)] - ] + [ (T.pack $ moduleNameString modName, sp) + | imp <- gre_imp gre + , let modName = +#if MIN_VERSION_ghc(9,7,0) + moduleName $ is_mod (is_decl imp) +#else + is_mod (is_decl imp) +#endif + , RealSrcSpan sp _ <- [is_dloc (is_decl imp)] + ] suggests :: T.Text -> RealSrcSpan -> [(T.Text, [Either TextEdit Rewrite])] suggests modName s' @@ -462,8 +469,47 @@ isUnusedImportedId maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs | otherwise = False -suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] -suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents fd = +suggestRemoveRedundantImportBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImportBinding pm contents fd = +#if MIN_VERSION_ghc(9,7,0) + suggestRemoveRedundantImportStructured pm contents fd +#else + suggestRemoveRedundantImportRegex pm contents (fdLspDiagnostic fd) +#endif + +#if !MIN_VERSION_ghc(9,7,0) +suggestRemoveRedundantImportRegex :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImportRegex ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} +-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant + | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" + , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports + , Just c <- contents + , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings >>= trySplitIntoOriginalAndRecordField) + , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) + , not (null ranges') + = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] + +-- File.hs:16:1: warning: +-- The import of `Data.List' is redundant +-- except perhaps to import instances from `Data.List' +-- To import instances alone, use: import Data.List() + | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) + = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] + | otherwise = [] + where + -- In case of an unused record field import, the binding from the message will not match any import directly + -- In this case, we try if we can additionally extract a record field name + -- Example: The import of ‘B(b2)’ from module ‘ModuleB’ is redundant + trySplitIntoOriginalAndRecordField :: T.Text -> [T.Text] + trySplitIntoOriginalAndRecordField binding = + case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of + Just [_, fields] -> [binding, fields] + _ -> [binding] +#endif + +#if MIN_VERSION_ghc(9,7,0) +suggestRemoveRedundantImportStructured :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImportStructured ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents fd = case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of Just (TcRnUnusedImport impDecl reason) -> let wantedModule = moduleNameString $ unLoc $ ideclName impDecl @@ -502,6 +548,7 @@ unusedImportNameText (UnusedImportNameRecField parent occName) = case parent of ParentIs name -> T.pack (getOccString name) <> "(" <> T.pack (occNameString occName) <> ")" NoParent -> T.pack (occNameString occName) -- Fallback safety (unlikely) +#endif diagInRange :: Diagnostic -> Range -> Bool diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange @@ -519,7 +566,7 @@ diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents allDiags contextRange uri | Just pm <- m, - r <- join $ map (\fd -> let d = fdLspDiagnostic fd in repeat d `zip` suggestRemoveRedundantImport pm contents fd) allDiags, + r <- join $ map (\fd -> let d = fdLspDiagnostic fd in repeat d `zip` suggestRemoveRedundantImportBinding pm contents fd) allDiags, allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], caRemoveAll <- removeAll allEdits, ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange], @@ -621,16 +668,32 @@ suggestRemoveRedundantExport _ _ = Nothing suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] suggestDeleteUnusedBinding pm contents fd = - case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of - Just (TcRnUnusedName occName prov) - | isLocalUnusedName prov -> suggestDeleteUnusedBindingByName pm contents (T.pack $ occNameString occName) (fdLspDiagnostic fd) - _ -> [] +#if MIN_VERSION_ghc(9,7,0) + suggestDeleteUnusedBindingStructured pm contents fd +#else + suggestDeleteUnusedBindingRegex pm contents (fdLspDiagnostic fd) +#endif + +#if MIN_VERSION_ghc(9,7,0) +suggestDeleteUnusedBindingStructured :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBindingStructured pm contents fd + | Just (TcRnUnusedName occName prov) <- fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage + , isLocalUnusedName prov + = suggestDeleteUnusedBindingByName pm contents (T.pack $ occNameString occName) (fdLspDiagnostic fd) + | otherwise = [] isLocalUnusedName :: UnusedNameProv -> Bool isLocalUnusedName UnusedNameTopDecl = True isLocalUnusedName UnusedNameLocalBind = True isLocalUnusedName UnusedNameMatch = True isLocalUnusedName _ = False +#else +suggestDeleteUnusedBindingRegex :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBindingRegex pm contents diag@Diagnostic{_message} + | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + = suggestDeleteUnusedBindingByName pm contents name diag + | otherwise = [] +#endif suggestDeleteUnusedBindingByName :: ParsedModule -> Maybe T.Text -> T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDeleteUnusedBindingByName ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} contents name Diagnostic{_range=_range} @@ -754,13 +817,25 @@ getLocatedRange = srcSpanToRange . getLoc suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit) suggestExportUnusedTopBinding srcOpt pm fd = --- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ --- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ --- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ - case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of - Just (TcRnUnusedName occName UnusedNameTopDecl) -> - suggestExportUnusedTopBindingByName srcOpt pm (T.pack $ occNameString occName) (fdLspDiagnostic fd) - _ -> Nothing +#if MIN_VERSION_ghc(9,7,0) + suggestExportUnusedTopBindingStructured srcOpt pm fd +#else + suggestExportUnusedTopBindingRegex srcOpt pm (fdLspDiagnostic fd) +#endif + +#if MIN_VERSION_ghc(9,7,0) +suggestExportUnusedTopBindingStructured :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBindingStructured srcOpt pm fd + | Just (TcRnUnusedName occName UnusedNameTopDecl) <- fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage + = suggestExportUnusedTopBindingByName srcOpt pm (T.pack $ occNameString occName) (fdLspDiagnostic fd) + | otherwise = Nothing +#else +suggestExportUnusedTopBindingRegex :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBindingRegex srcOpt pm diag@Diagnostic{_message} + | Just [_, name] <- matchRegexUnifySpaces _message ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’" + = suggestExportUnusedTopBindingByName srcOpt pm name diag + | otherwise = Nothing +#endif suggestExportUnusedTopBindingByName :: Maybe T.Text -> ParsedModule -> T.Text -> Diagnostic -> Maybe (T.Text, TextEdit) suggestExportUnusedTopBindingByName srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} name Diagnostic{..} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index 92879fa412..5a25a7fec8 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -12,6 +12,7 @@ import Development.IDE.GHC.ExactPrint (modifyMgMatchesT', modifySigWithM, modifySmallestDeclWithM) import Development.IDE.Plugin.Plugins.Diagnostic +import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic)) import GHC.Parser.Annotation (SrcSpanAnnA, SrcSpanAnnN, noAnn) import Ide.Plugin.Error (PluginError (PluginInternalError)) @@ -32,7 +33,6 @@ import GHC.Parser.Annotation (TokenLocation (..)) #if !MIN_VERSION_ghc(9,9,0) import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst) import Development.IDE.GHC.ExactPrint (genAnchor1) -import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic)) import GHC.Parser.Annotation (EpAnn (..), SrcSpanAnn' (..), emptyComments) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs index e256e4023f..2c9ab9b01e 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Plugins.FillHole ( suggestFillHole ) where @@ -8,17 +9,16 @@ import Data.Char import qualified Data.HashSet as Set import qualified Data.Text as T import Development.IDE (FileDiagnostic, + _message, fdLspDiagnosticL, printOutputable) -import Development.IDE.GHC.Compat (ParsedModule, SDoc, - defaultSDocContext, +import Development.IDE.GHC.Compat (ParsedModule, hsmodImports, ideclAs, ideclName, ideclQualified, lookupOccEnv, moduleNameString, pm_parsed_source, - renderWithContext, unLoc) import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (TcRnMessageDetailed), _TcRnMessageWithCtx, @@ -32,7 +32,6 @@ import Development.IDE.Types.Exports (ExportsMap (..), mkVarOrDataOcc, moduleNameText) import GHC.Tc.Errors.Types (ErrInfo (ErrInfo)) -import Ide.PluginUtils (unescape) import Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..)) import Language.LSP.Protocol.Lens (HasRange (..)) import Language.LSP.Protocol.Types (TextEdit (TextEdit)) @@ -42,11 +41,20 @@ import Text.Regex.TDFA (MatchResult (..), suggestFillHole :: ExportsMap -> ParsedModule -> FileDiagnostic -> [(T.Text, TextEdit)] suggestFillHole exportsMap pm diag | Just holeName <- extractHoleName diag +#if MIN_VERSION_ghc(9,13,0) + , Just _errInfo <- extractErrInfo diag + , let supplText = _message (diag ^. fdLspDiagnosticL) + , let ctxText = supplText +#else , Just (ErrInfo ctx suppl) <- extractErrInfo diag - , (holeFits, refFits) <- processHoleSuggestions $ T.lines (printErr suppl) = - let isInfixHole = printErr ctx =~ addBackticks holeName :: Bool in + , let ctxText = printOutputable ctx + , let supplText = printOutputable suppl +#endif + , let (holeFits, refFits) = processHoleSuggestions (T.lines supplText) + , let isInfixHole = ctxText =~ addBackticks holeName :: Bool = map (proposeHoleFit holeName False isInfixHole) holeFits - ++ map (proposeHoleFit holeName True isInfixHole) refFits + ++ + map (proposeHoleFit holeName True isInfixHole) refFits | otherwise = [] where qualify = qualifyFit exportsMap pm @@ -66,9 +74,6 @@ suggestFillHole exportsMap pm diag . _TcRnMessageWithInfo Just errInfo - printErr :: SDoc -> T.Text - printErr = unescape . T.pack . renderWithContext defaultSDocContext - addBackticks :: T.Text -> T.Text addBackticks text = "`" <> text <> "`" From 585a2559618066e85c42603fa3ba605347aa0a6c Mon Sep 17 00:00:00 2001 From: vidit-od Date: Thu, 12 Mar 2026 13:46:48 +0530 Subject: [PATCH 3/3] Fix indentations and spacings + better use structured information Fix a lot of spacing and indentation inconsistences, also propagate structured info further to better use it instead of direct conversion to string. --- .../src/Development/IDE/Plugin/CodeAction.hs | 30 ++++----- .../IDE/Plugin/Plugins/AddArgument.hs | 47 ++++++------- .../IDE/Plugin/Plugins/Diagnostic.hs | 20 ++---- .../IDE/Plugin/Plugins/FillHole.hs | 66 +++++++++---------- 4 files changed, 74 insertions(+), 89 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 d6de916a21..7b791bb502 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1025,23 +1025,23 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range,..} suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] suggestNewDefinition ideOptions parsedModule contents fd - | Just (name, typ) <- matchVariableNotInScope fd = - newDefinitionAction ideOptions parsedModule _range name typ - | Just (name, typ) <- matchFoundHole fd - , let definedName = fromMaybe name (T.stripPrefix "_" name) - , let typ' = case T.stripPrefix "_" name of - Nothing | isPlainTyVar typ -> Nothing - _ -> Just typ - , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ' = + | Just (rdrName, typ) <- matchVariableNotInScope fd = + newDefinitionAction ideOptions parsedModule _range rdrName typ + | Just (rdrName, typ) <- matchFoundHole fd + , let occName = rdrNameOcc rdrName + , let isHole = "_" `isPrefixOf` occNameString occName + , let definedName = printOutputable (if isHole then mkOccName (occNameSpace occName) (drop 1 (occNameString occName)) else occName) + , let typ' = if isHole || not (isPlainTyVar typ) then Just typ else Nothing + , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range rdrName typ' = [(label, mkRenameEdit contents _range definedName : newDefinitionEdits)] | otherwise = [] where Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic -- A "plain type variable" is a single lowercase word like p, a etc - isPlainTyVar t = T.all (\c -> isAlphaNum c || c == '_') t && not (T.null t) && isLower (T.head t) + isPlainTyVar = isJust . getTyVar_maybe -newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])] -newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ +newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> RdrName -> Maybe Type -> [(T.Text, [TextEdit])] +newDefinitionAction IdeOptions {..} parsedModule Range {_start} rdrName typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls, @@ -1055,11 +1055,11 @@ newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ | otherwise = [] where colon = if optNewColonConvention then " : " else " :: " + occName = rdrNameOcc rdrName definedName = - case T.stripPrefix "_" name of - Just n -> n - Nothing -> name - sig = definedName <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ) + let name = occNameString occName + in T.pack $ if "_" `isPrefixOf` name then drop 1 name else name + sig = definedName <> colon <> T.dropWhileEnd isSpace (maybe "_" printOutputable typ) ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule {- Handles two variants with different formatting diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index 5a25a7fec8..c9f73bafb8 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -69,42 +69,39 @@ type HsArrow pass = HsMultAnn pass -- In this case a new argument would have to add its type between b and c in the signature. plugin :: ParsedModule -> FileDiagnostic -> Either PluginError [(T.Text, [TextEdit])] plugin parsedModule fd - | Just (name, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range name typ - | Just (name, typ) <- matchFoundHoleIncludeUnderscore fd = addArgumentAction parsedModule _range name (Just typ) + | Just (rdrName, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range rdrName typ + | Just (rdrName, typ) <- matchFoundHole fd = addArgumentAction parsedModule _range rdrName (Just typ) | otherwise = pure [] where - Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic + Diagnostic{_message, _range} = fdLspDiagnostic fd -- Given a name for the new binding, add a new pattern to the match in the last position, -- returning how many patterns there were in this match prior to the transformation: -- addArgToMatch "foo" `bar arg1 arg2 = ...` -- => (`bar arg1 arg2 foo = ...`, 2) -addArgToMatch :: T.Text -> GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))) -> (GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))), Int) +addArgToMatch :: RdrName -> GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))) -> (GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))), Int) -- NOTE: The code duplication within CPP clauses avoids a parse error with -- `stylish-haskell`. #if MIN_VERSION_ghc(9,11,0) -addArgToMatch name (L locMatch (Match xMatch ctxMatch (L l pats) rhs)) = - let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name - newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName +addArgToMatch unqualName (L locMatch (Match xMatch ctxMatch (L l pats) rhs)) = + let newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between -- the newly added pattern and the rest indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs)) indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs } in (L locMatch (Match xMatch ctxMatch (L l (pats <> [newPat])) (indentRhs rhs)), Prelude.length pats) #elif MIN_VERSION_ghc(9,9,0) -addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = - let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name - newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName +addArgToMatch unqualName (L locMatch (Match xMatch ctxMatch pats rhs)) = + let newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between -- the newly added pattern and the rest indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs)) indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs } in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats) #else -addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = - let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name - newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) +addArgToMatch unqualName (L locMatch (Match xMatch ctxMatch pats rhs)) = + let newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) indentRhs = id in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats) #endif @@ -117,10 +114,10 @@ addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = -- For example: -- insertArg "new_pat" `foo bar baz = 1` -- => (`foo bar baz new_pat = 1`, Just ("foo", 2)) -appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int)) -appendFinalPatToMatches name = \case +appendFinalPatToMatches :: RdrName -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int)) +appendFinalPatToMatches rdrName = \case (L locDecl (ValD xVal fun@FunBind{fun_matches=mg,fun_id = idFunBind})) -> do - (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats + (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch rdrName) Nothing combineMatchNumPats numPats <- TransformT $ lift $ maybeToEither (PluginInternalError "Unexpected empty match group in HsDecl") numPatsMay let decl' = L locDecl (ValD xVal fun{fun_matches=mg'}) pure (decl', Just (idFunBind, numPats)) @@ -143,8 +140,8 @@ appendFinalPatToMatches name = \case -- foo () = new_def -- -- TODO instead of inserting a typed hole; use GHC's suggested type from the error -addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] -addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do +addArgumentAction :: ParsedModule -> Range -> RdrName -> Maybe Type -> Either PluginError [(T.Text, [TextEdit])] +addArgumentAction (ParsedModule _ moduleSrc _) range rdrName _typ = do (newSource, _, _) <- runTransformT $ do (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl #if MIN_VERSION_ghc(9,9,0) @@ -153,17 +150,15 @@ addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do (makeDeltaAst moduleSrc) #endif case matchedDeclNameMay of - Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' - Nothing -> pure moduleSrc' + Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' + Nothing -> pure moduleSrc' let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource) - pure [("Add argument ‘" <> definedName <> "’ to function", diff)] + pure [("Add argument ‘" <> labelName <> "’ to function", diff)] where addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg - addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches definedName - definedName = - case T.stripPrefix "_" name of - Just n -> n - Nothing -> name + addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches rdrName + occName = rdrNameOcc rdrName + labelName = T.pack $ occNameString occName spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range) -- Transform an LHsType into a list of arguments and return type, to make transformations easier. diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs index 8876675355..0fdacd1416 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs @@ -5,16 +5,13 @@ module Development.IDE.Plugin.Plugins.Diagnostic ( matchRegexUnifySpaces, unifySpaces, matchFoundHole, - matchFoundHoleIncludeUnderscore, diagReportHoleError ) where import Control.Lens -import Data.Bifunctor (Bifunctor (..)) import qualified Data.Text as T -import Development.IDE (printOutputable) -import Development.IDE.GHC.Compat (RdrName) +import Development.IDE.GHC.Compat (RdrName, Type) import Development.IDE.GHC.Compat.Error (Hole, _ReportHoleError, _TcRnMessage, _TcRnNotInScope, @@ -43,20 +40,18 @@ matchRegex message regex = case message =~~ regex of matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] matchRegexUnifySpaces message = matchRegex (unifySpaces message) -matchFoundHole :: FileDiagnostic -> Maybe (T.Text, T.Text) +matchFoundHole :: FileDiagnostic -> Maybe (RdrName, Type) matchFoundHole fd = do hole <- diagReportHoleError fd - Just (printOutputable (hole_occ hole), printOutputable (hole_ty hole)) + Just (hole_occ hole, hole_ty hole) -matchFoundHoleIncludeUnderscore :: FileDiagnostic -> Maybe (T.Text, T.Text) -matchFoundHoleIncludeUnderscore fd = first ("_" <>) <$> matchFoundHole fd - -matchVariableNotInScope :: FileDiagnostic -> Maybe (T.Text, Maybe T.Text) +matchVariableNotInScope :: FileDiagnostic -> Maybe (RdrName, Maybe Type) matchVariableNotInScope fd = do (rdrName, _) <- diagReportNotInScope fd - Just (printOutputable rdrName, Nothing) + Just (rdrName, Nothing) --- | Extract the 'Hole' out of a 'FileDiagnostic' +-- | Extract the typed hole information from a diagnostic, if the diagnostic +-- originates from a hole. Returns 'Nothing' for any other kind of diagnostic. diagReportHoleError :: FileDiagnostic -> Maybe Hole diagReportHoleError diag = do solverReport <- @@ -68,7 +63,6 @@ diagReportHoleError diag = do . _TcRnSolverReport . _1 (hole, _) <- solverReport ^? reportContentL . _ReportHoleError - Just hole -- | Extract the 'NotInScopeError' and the corresponding 'RdrName' from a 'FileDiagnostic' diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs index 2c9ab9b01e..0886d9b864 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -9,7 +9,6 @@ import Data.Char import qualified Data.HashSet as Set import qualified Data.Text as T import Development.IDE (FileDiagnostic, - _message, fdLspDiagnosticL, printOutputable) import Development.IDE.GHC.Compat (ParsedModule, @@ -33,7 +32,8 @@ import Development.IDE.Types.Exports (ExportsMap (..), moduleNameText) import GHC.Tc.Errors.Types (ErrInfo (ErrInfo)) import Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..)) -import Language.LSP.Protocol.Lens (HasRange (..)) +import Language.LSP.Protocol.Lens (HasRange (..), + message) import Language.LSP.Protocol.Types (TextEdit (TextEdit)) import Text.Regex.TDFA (MatchResult (..), (=~)) @@ -43,12 +43,12 @@ suggestFillHole exportsMap pm diag | Just holeName <- extractHoleName diag #if MIN_VERSION_ghc(9,13,0) , Just _errInfo <- extractErrInfo diag - , let supplText = _message (diag ^. fdLspDiagnosticL) + , let supplText = diag ^. fdLspDiagnosticL . message , let ctxText = supplText #else , Just (ErrInfo ctx suppl) <- extractErrInfo diag - , let ctxText = printOutputable ctx , let supplText = printOutputable suppl + , let ctxText = printOutputable ctx #endif , let (holeFits, refFits) = processHoleSuggestions (T.lines supplText) , let isInfixHole = ctxText =~ addBackticks holeName :: Bool = @@ -57,8 +57,6 @@ suggestFillHole exportsMap pm diag map (proposeHoleFit holeName True isInfixHole) refFits | otherwise = [] where - qualify = qualifyFit exportsMap pm - extractHoleName :: FileDiagnostic -> Maybe T.Text extractHoleName d = do hole <- diagReportHoleError d @@ -85,7 +83,7 @@ suggestFillHole exportsMap pm diag case T.uncons name of Nothing -> error "impossible: empty name provided by ghc" Just (firstChr, _) -> - let cleanName = qualify (stripUnique name) + let cleanName = (qualifyFit exportsMap pm) (stripUnique name) isInfixOperator = firstChr == '(' name' = getOperatorNotation isInfixHole isInfixOperator cleanName replacement = if parenthise then addParens name' else name' @@ -114,49 +112,47 @@ suggestFillHole exportsMap pm diag qualifyFit :: ExportsMap -> ParsedModule -> T.Text -> T.Text qualifyFit exportsMap pm fitName = case findQualifier of - Nothing -> fitName - Just qualifier -> qualifier <> "." <> fitName - where - -- All modules that export this name - exportingModules :: [T.Text] - exportingModules = + Nothing -> fitName + Just qualifier -> qualifier <> "." <> fitName + where + -- All modules that export this name + exportingModules :: [T.Text] + exportingModules = let occ = mkVarOrDataOcc fitName identSet = lookupOccEnv (getExportsMap exportsMap) occ idents = maybe [] Set.toList identSet - in map moduleNameText idents + in map moduleNameText idents - -- All qualified imports from this file: (moduleName, qualifier) - qualifiedImports :: [(T.Text, T.Text)] - qualifiedImports = + -- All qualified imports from this file: (moduleName, qualifier) + importQualifiers :: [(T.Text, T.Text)] + importQualifiers = let imports = hsmodImports . unLoc . pm_parsed_source $ pm - in [ (modName decl, qualifier decl) + in [ (modName decl, extractQualifier decl) | i <- imports , let decl = unLoc i - , isQualified decl + , ideclQualified decl `elem` [QualifiedPre, QualifiedPost] ] - isQualified decl = ideclQualified decl `elem` [QualifiedPre, QualifiedPost] - - modName decl = - T.pack . moduleNameString . unLoc . ideclName $ decl + -- extract the module name from declaration + modName decl = T.pack . moduleNameString . unLoc . ideclName $ decl - qualifier decl = + -- extract the qualifier alias of import declaration (if present) + extractQualifier decl = case ideclAs decl of - Just alias -> T.pack . moduleNameString . unLoc $ alias - Nothing -> modName decl + Just alias -> T.pack . moduleNameString . unLoc $ alias + Nothing -> modName decl - -- Find first qualified import whose module is in the exporting modules list - findQualifier :: Maybe T.Text - findQualifier = + -- Find first qualified import whose module is in the exporting modules list + findQualifier :: Maybe T.Text + findQualifier = let exportingSet = exportingModules in fmap snd - . safeHead - . filter (\(modN, _) -> modN `elem` exportingSet) - $ qualifiedImports - - safeHead [] = Nothing - safeHead (x:_) = Just x + . safeHead + . filter (\(modN, _) -> modN `elem` exportingSet) + $ importQualifiers + safeHead [] = Nothing + safeHead (x:_) = Just x processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) processHoleSuggestions mm = (holeSuggestions, refSuggestions)