From 2b269c46e6f2b69c7f25df10042b02fd4e26eab1 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 10 Jul 2025 22:54:10 -0400 Subject: [PATCH 1/3] Use structured diagnostics for type wildcard fill suggestions --- .../src/Development/IDE/GHC/Compat/Error.hs | 11 ++ .../IDE/Plugin/Plugins/FillTypeWildcard.hs | 131 +++++++++++------- plugins/hls-refactor-plugin/test/Main.hs | 32 ++++- 3 files changed, 115 insertions(+), 59 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index e4fb9c26b4..d5d952102a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Error.hs @@ -8,6 +8,7 @@ module Development.IDE.GHC.Compat.Error ( -- * Error messages for the typechecking and renamer phase TcRnMessage (..), TcRnMessageDetailed (..), + Hole(..), stripTcRnMessageContext, -- * Parsing error message PsMessage(..), @@ -23,9 +24,14 @@ module Development.IDE.GHC.Compat.Error ( _GhcPsMessage, _GhcDsMessage, _GhcDriverMessage, + _ReportHoleError, + _TcRnIllegalWildcardInType, + _TcRnPartialTypeSignatures, _TcRnMissingSignature, _TcRnSolverReport, _TcRnMessageWithInfo, + _TypeHole, + _ConstraintHole, reportContextL, reportContentL, _MismatchMessage, @@ -38,6 +44,7 @@ import Development.IDE.GHC.Compat (Type) import GHC.Driver.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint (Hole(..), HoleSort) import GHC.Types.Error -- | Some 'TcRnMessage's are nested in other constructors for additional context. @@ -95,6 +102,10 @@ makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) ''SolverReportWithCtxt +makePrisms ''TcSolverReportMsg + +makePrisms ''HoleSort + -- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be -- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors. _MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg 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 17db1f0298..e4a4eea586 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 @@ -2,78 +2,105 @@ module Development.IDE.Plugin.Plugins.FillTypeWildcard ( suggestFillTypeWildcard ) where -import Data.Char -import qualified Data.Text as T -import Language.LSP.Protocol.Types (Diagnostic (..), - TextEdit (TextEdit)) +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 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)) -suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] -suggestFillTypeWildcard Diagnostic{_range=_range,..} +suggestFillTypeWildcard :: FileDiagnostic -> [(T.Text, TextEdit)] +suggestFillTypeWildcard diag@FileDiagnostic{fdLspDiagnostic = Diagnostic {..}} -- Foo.hs:3:8: error: -- * Found type wildcard `_' standing for `p -> p1 -> p' - | "Found type wildcard" `T.isInfixOf` _message - , " standing for " `T.isInfixOf` _message - , typeSignature <- extractWildCardTypeSignature _message - = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] + | isWildcardDiagnostic diag + , typeSignature <- extractWildCardTypeSignature diag = + [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] | otherwise = [] +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 + (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 -- require understanding both the precedence of the context of the hole and of -- the signature itself. Inserting them (almost) unconditionally is ugly but safe. -extractWildCardTypeSignature :: T.Text -> T.Text -extractWildCardTypeSignature msg - | enclosed || not isApp || isToplevelSig = sig - | otherwise = "(" <> sig <> ")" - where - msgSigPart = snd $ T.breakOnEnd "standing for " msg - (sig, rest) = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart - -- If we're completing something like ‘foo :: _’ parens can be safely omitted. - isToplevelSig = errorMessageRefersToToplevelHole rest - -- Parenthesize type applications, e.g. (Maybe Char). - isApp = T.any isSpace sig - -- Do not add extra parentheses to lists, tuples and already parenthesized types. - enclosed = - case T.uncons sig of +extractWildCardTypeSignature :: FileDiagnostic -> T.Text +extractWildCardTypeSignature diag = + case hole_ty <$> diagReportHoleError diag of + Just ty + | isTopLevel || not (isApp ty) || enclosed ty -> printOutputable ty + | otherwise -> "(" <> printOutputable ty <> ")" Nothing -> error "GHC provided invalid type" - Just (firstChr, _) -> not (T.null sig) && (firstChr, T.last sig) `elem` [('(', ')'), ('[', ']')] + where + isTopLevel :: Bool + isTopLevel = + maybe False errorMessageRefersToToplevelHole (diagErrInfoContext diag) + + isApp :: Type -> Bool + isApp (AppTy _ _) = True + isApp (TyConApp _ (_ : _)) = True + isApp (FunTy{}) = True + isApp _ = False + + enclosed :: Type -> Bool + enclosed (TyConApp con _) + | con == listTyCon || isTupleTyCon con = True + enclosed _ = False + +-- | Extract the 'ErrInfo' context out of a 'FileDiagnostic' and render it to +-- 'Text' +diagErrInfoContext :: FileDiagnostic -> Maybe T.Text +diagErrInfoContext diag = do + (_, detailedMsg) <- + diag + ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessageWithCtx + . _TcRnMessageWithInfo + let TcRnMessageDetailed err _ = detailedMsg + ErrInfo errInfoCtx _ = err + + Just (printOutputable errInfoCtx) --- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@. +-- | Detect whether user wrote something like @foo :: _@ or @foo :: Maybe _@. -- The former is considered toplevel case for which the function returns 'True', -- the latter is not toplevel and the returned value is 'False'. -- --- When type hole is at toplevel then there’s a line starting with --- "• In the type signature" which ends with " :: _" like in the +-- When type hole is at toplevel then the ErrInfo context starts with +-- "In the type signature" which ends with " :: _" like in the -- following snippet: -- --- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error: --- • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’ --- To use the inferred type, enable PartialTypeSignatures --- • In the type signature: decl :: _ --- In an equation for ‘splitAnnots’: --- splitAnnots m@HsModule {hsmodAnn, hsmodDecls} --- = undefined --- where --- ann :: SrcSpanAnnA --- decl :: _ --- L ann decl = head hsmodDecls --- • Relevant bindings include --- [REDACTED] +-- Just "In the type signature: decl :: _" -- -- When type hole is not at toplevel there’s a stack of where -- the hole was located ending with "In the type signature": -- --- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error: --- • Found type wildcard ‘_’ standing for ‘GhcPs’ --- To use the inferred type, enable PartialTypeSignatures --- • In the first argument of ‘HsDecl’, namely ‘_’ --- In the type ‘HsDecl _’ --- In the type signature: decl :: HsDecl _ --- • Relevant bindings include --- [REDACTED] +-- Just "In the first argument of ‘HsDecl’\nIn the type signature: decl :: HsDecl _" errorMessageRefersToToplevelHole :: T.Text -> Bool errorMessageRefersToToplevelHole msg = - not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest - where - (prefix, rest) = T.breakOn "• In the type signature:" msg + "In the type signature:" `T.isPrefixOf` msg + && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') msg diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index b06b41ccba..508d480c63 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -701,6 +701,10 @@ typeWildCardActionTests = testGroup "type wildcard actions" "func::Integer -> Integer -> Integer" , "func x y = x + y" ] + , testNoUseTypeSignature "ignores typed holes" + [ "func :: a -> a" + , "func x = _" + ] , testGroup "add parens if hole is part of bigger type" [ testUseTypeSignature "subtype 1" [ "func :: _ -> Integer -> Integer" @@ -736,19 +740,33 @@ typeWildCardActionTests = testGroup "type wildcard actions" -- | Test session of given name, checking action "Use type signature..." -- on a test file with given content and comparing to expected result. testUseTypeSignature name textIn textOut = testSession name $ do - let fileStart = "module Testing where" + let expectedContentAfterAction = T.unlines $ fileStart : textOut content = T.unlines $ fileStart : textIn - expectedContentAfterAction = T.unlines $ fileStart : textOut doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - [addSignature] <- pure [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isPrefixOf` actionTitle - ] + + (Just addSignature) <- getUseTypeSigAction doc executeCodeAction addSignature contentAfterAction <- documentContents doc liftIO $ expectedContentAfterAction @=? contentAfterAction + testNoUseTypeSignature name textIn = testSession name $ do + let content = T.unlines $ fileStart : textIn + doc <- createDoc "Testing.hs" "haskell" content + codeAction <- getUseTypeSigAction doc + liftIO $ Nothing @=? codeAction + + fileStart = "module Testing where" + + getUseTypeSigAction docIn = do + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions docIn + + let addSignatures = + [ action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isPrefixOf` actionTitle + ] + pure $ listToMaybe addSignatures + removeImportTests :: TestTree removeImportTests = testGroup "remove import actions" From 6edb82cc976e05cc3586bb03ee5d2945a495c2f3 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 16 Jul 2025 10:14:52 -0400 Subject: [PATCH 2/3] Fix formatting --- ghcide/src/Development/IDE/GHC/Compat/Error.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index d5d952102a..de59afa146 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Error.hs @@ -44,7 +44,7 @@ import Development.IDE.GHC.Compat (Type) import GHC.Driver.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint (Hole(..), HoleSort) +import GHC.Tc.Types.Constraint (Hole (..), HoleSort) import GHC.Types.Error -- | Some 'TcRnMessage's are nested in other constructors for additional context. From 796038db0ff2d6d8aa348860ba9fbdb17bb5ac50 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 17 Jul 2025 14:22:49 -0400 Subject: [PATCH 3/3] Fix compilation error for GHC-9.10+ for hls-refactor-plugin --- .../src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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 e4a4eea586..0f06fff2f7 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 @@ -31,13 +31,14 @@ isWildcardDiagnostic = -- | Extract the 'Hole' out of a 'FileDiagnostic' diagReportHoleError :: FileDiagnostic -> Maybe Hole diagReportHoleError diag = do - (solverReport, _, _) <- + solverReport <- diag ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage . _TcRnSolverReport + . _1 (hole, _) <- solverReport ^? reportContentL . _ReportHoleError Just hole