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..7b791bb502 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,10 @@ 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 (..)) #if !MIN_VERSION_ghc(9,11,0) import Development.IDE.GHC.Compat.Util #endif @@ -128,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 ------------------------------------------------------------------------------------------------- @@ -138,7 +147,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 +385,50 @@ 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 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' + | 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,8 +469,17 @@ 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,..} +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 @@ -474,6 +505,50 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod 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 + 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) +#endif diagInRange :: Diagnostic -> Range -> Bool diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange @@ -488,10 +563,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` suggestRemoveRedundantImportBinding pm contents fd) allDiags, allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], caRemoveAll <- removeAll allEdits, ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange], @@ -518,7 +593,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 +611,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 +666,38 @@ 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’ +suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBinding pm contents 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: ‘([^ ]+)’" - , Just indexedContent <- indexedByPosition . T.unpack <$> contents + = 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} + | 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 +815,31 @@ 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{..} --- 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’ +suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit) +suggestExportUnusedTopBinding srcOpt pm fd = +#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{..} | 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,19 +1023,25 @@ 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 = - 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)] +suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])] +suggestNewDefinition ideOptions parsedModule contents fd + | 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 - message = unifySpaces _message + Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic + -- A "plain type variable" is a single lowercase word like p, a etc + 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, @@ -929,13 +1049,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) + occName = rdrNameOcc rdrName + definedName = + 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 @@ -1364,74 +1488,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..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 @@ -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)) @@ -66,44 +67,41 @@ 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 (rdrName, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range rdrName typ + | Just (rdrName, typ) <- matchFoundHole fd = addArgumentAction parsedModule _range rdrName (Just typ) | otherwise = pure [] where - message = unifySpaces _message + 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 @@ -116,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)) @@ -142,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) @@ -152,14 +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 ‘" <> name <> "’ to function", diff)] + pure [("Add argument ‘" <> labelName <> "’ to function", diff)] where addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg - addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches 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 7facc8f54c..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 @@ -1,15 +1,28 @@ +{-# 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 qualified Data.Text as T +import Development.IDE.GHC.Compat (RdrName, Type) +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 +40,50 @@ 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 (RdrName, Type) +matchFoundHole fd = do + hole <- diagReportHoleError fd + Just (hole_occ hole, hole_ty hole) + +matchVariableNotInScope :: FileDiagnostic -> Maybe (RdrName, Maybe Type) +matchVariableNotInScope fd = do + (rdrName, _) <- diagReportNotInScope fd + Just (rdrName, Nothing) + +-- | 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 <- + 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..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 @@ -1,43 +1,158 @@ +{-# LANGUAGE CPP #-} 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, + hsmodImports, + ideclAs, ideclName, + ideclQualified, + lookupOccEnv, + moduleNameString, + pm_parsed_source, + 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 Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..)) +import Language.LSP.Protocol.Lens (HasRange (..), + message) +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 +#if MIN_VERSION_ghc(9,13,0) + , Just _errInfo <- extractErrInfo diag + , let supplText = diag ^. fdLspDiagnosticL . message + , let ctxText = supplText +#else + , Just (ErrInfo ctx suppl) <- extractErrInfo diag + , let supplText = printOutputable suppl + , let ctxText = printOutputable ctx +#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 - extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + 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 + + 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 = (qualifyFit exportsMap pm) (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) + importQualifiers :: [(T.Text, T.Text)] + importQualifiers = + let imports = hsmodImports . unLoc . pm_parsed_source $ pm + in [ (modName decl, extractQualifier decl) + | i <- imports + , let decl = unLoc i + , ideclQualified decl `elem` [QualifiedPre, QualifiedPost] + ] + + -- extract the module name from declaration + modName decl = T.pack . moduleNameString . unLoc . ideclName $ 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 + + -- 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) + $ importQualifiers + + 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