From be251f4fc14a7150b0d6308cbee4a3082993b33d Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 19 Aug 2025 16:42:31 -0400 Subject: [PATCH 1/3] Use structured diagnostics for typed hole suggestions --- .../IDE/Plugin/Plugins/Diagnostic.hs | 31 +++++- .../IDE/Plugin/Plugins/FillHole.hs | 100 ++++++++++++------ .../IDE/Plugin/Plugins/FillTypeWildcard.hs | 36 ++----- plugins/hls-refactor-plugin/test/Main.hs | 26 +++++ 4 files changed, 134 insertions(+), 59 deletions(-) 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..1275209aa7 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 @@ -4,12 +4,22 @@ module Development.IDE.Plugin.Plugins.Diagnostic ( unifySpaces, matchFoundHole, matchFoundHoleIncludeUnderscore, + diagReportHoleError, ) where -import Data.Bifunctor (Bifunctor (..)) -import qualified Data.Text as T -import Text.Regex.TDFA ((=~~)) +import Control.Lens (_1, (^?)) +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic) +import Development.IDE.GHC.Compat.Error (Hole, _ReportHoleError, + _TcRnMessage, + _TcRnSolverReport, + msgEnvelopeErrorL, + reportContentL) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage, + fdStructuredMessageL) +import Text.Regex.TDFA ((=~~)) unifySpaces :: T.Text -> T.Text unifySpaces = T.unwords . T.words @@ -57,3 +67,18 @@ matchVariableNotInScope message | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" = Just name | otherwise = 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 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..0e25d36988 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,25 +2,40 @@ module Development.IDE.Plugin.Plugins.FillHole ( suggestFillHole ) where -import Control.Monad (guard) +import Control.Lens +import Control.Monad (guard) import Data.Char -import qualified Data.Text as T -import Development.IDE.Plugin.Plugins.Diagnostic -import Language.LSP.Protocol.Types (Diagnostic (..), - TextEdit (TextEdit)) -import Text.Regex.TDFA (MatchResult (..), - (=~)) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + fdLspDiagnosticL, + printOutputable) +import Development.IDE.GHC.Compat (defaultSDocContext, + renderWithContext, SDoc) +import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (..), + _TcRnMessageWithCtx, + _TcRnMessageWithInfo, + hole_occ, + msgEnvelopeErrorL) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage, + fdStructuredMessageL) +import GHC.Tc.Errors.Types (ErrInfo (..)) +import Ide.PluginUtils (unescape) +import Language.LSP.Protocol.Lens (HasRange (..)) +import Language.LSP.Protocol.Types (TextEdit (..)) +import Text.Regex.TDFA (MatchResult (..), (=~)) +import GHC.Utils.Outputable (SDocContext(..)) +import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError) -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 - map (proposeHoleFit holeName False isInfixHole) holeFits - ++ map (proposeHoleFit holeName True isInfixHole) refFits +suggestFillHole :: FileDiagnostic -> [(T.Text, TextEdit)] +suggestFillHole diag + | Just holeName <- extractHoleName diag + , Just (ErrInfo ctx suppl) <- extractErrInfo diag + , (holeFits, refFits) <- processHoleSuggestions $ T.lines (printErr suppl) = do + 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: ([^ ]*)" addBackticks text = "`" <> text <> "`" addParens text = "(" <> text <> ")" proposeHoleFit holeName parenthise isInfixHole name = @@ -30,14 +45,30 @@ suggestFillHole Diagnostic{_range=_range,..} let isInfixOperator = firstChr == '(' name' = getOperatorNotation isInfixHole isInfixOperator name in ( "Replace " <> holeName <> " with " <> name - , TextEdit _range (if parenthise then addParens name' else name') + , TextEdit + (diag ^. fdLspDiagnosticL . range) + (if parenthise then addParens name' else name') ) 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 + +extractHoleName :: FileDiagnostic -> Maybe T.Text +extractHoleName diag = do + hole <- diagReportHoleError diag + Just $ printOutputable (hole_occ hole) + +extractErrInfo :: FileDiagnostic -> Maybe ErrInfo +extractErrInfo diag = do + (_, TcRnMessageDetailed errInfo _) <- + diag + ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessageWithCtx + . _TcRnMessageWithInfo + + Just errInfo processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) processHoleSuggestions mm = (holeSuggestions, refSuggestions) @@ -76,22 +107,19 @@ processHoleSuggestions mm = (holeSuggestions, refSuggestions) -- get the text indented under Valid refinement hole fits refinementSection <- getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm - case refinementSection of - [] -> error "GHC provided invalid hole fit options" - (_:refinementSection) -> do - -- get the text for each hole fit - holeFitLines <- getIndentedGroups refinementSection - let holeFit = T.strip $ T.unwords holeFitLines - guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" - return holeFit + -- Valid refinement hole fits line can contain a hole fit + refinementFitLine <- + mapHead + (mrAfter . (=~ t " *Valid refinement hole fits include")) + refinementSection + let refinementHoleFit = T.strip $ T.takeWhile (/= ':') refinementFitLine + guard $ not $ refinementHoleFit =~ t "Some refinement hole fits suppressed" + guard $ not $ T.null refinementHoleFit + return refinementHoleFit mapHead f (a:aa) = f a : aa mapHead _ [] = [] --- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] -getIndentedGroups :: [T.Text] -> [[T.Text]] -getIndentedGroups [] = [] -getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll -- | -- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] @@ -103,3 +131,13 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of indentation :: T.Text -> Int indentation = T.length . T.takeWhile isSpace +printErr :: SDoc -> T.Text +printErr = + unescape + . T.pack + . renderWithContext + ( defaultSDocContext + { sdocCanUseUnicode = False + , sdocSuppressUniques = True + } + ) 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 0f06fff2f7..262cf902f0 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 @@ -3,17 +3,18 @@ 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)) suggestFillTypeWildcard :: FileDiagnostic -> [(T.Text, TextEdit)] suggestFillTypeWildcard diag@FileDiagnostic{fdLspDiagnostic = Diagnostic {..}} @@ -28,21 +29,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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 0fb8b61f83..98fcd91d44 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -2918,6 +2918,32 @@ fillTypedHoleTests = let executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "<$>" @=? modifiedCode + , testSession "fill hole with one suggestion" $ do + let mkDoc a = T.unlines + [ "module Testing where" + , "test :: a -> a" + , "test a = " <> a + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 0) (Position 2 maxBound)) + chosen <- pickActionWithTitle "Replace _ with a" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "a" @=? modifiedCode + , testSession "fill hole with one refinement suggestion" $ do + let mkDoc a = T.unlines + [ "module Testing where" + , "test :: a -> a" + , "test a = " <> a + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 0) (Position 2 maxBound)) + chosen <- pickActionWithTitle "Replace _ with test _" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "(test _)" @=? modifiedCode ] addInstanceConstraintTests :: TestTree From a6d6113e7730b87b1804ca4394071ac86c3f2ec3 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 19 Aug 2025 16:56:26 -0400 Subject: [PATCH 2/3] doc: Add debugging note --- .../src/Development/IDE/Plugin/Plugins/FillHole.hs | 5 +++++ 1 file changed, 5 insertions(+) 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 0e25d36988..a2c041e2fa 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 @@ -131,6 +131,11 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of indentation :: T.Text -> Int indentation = T.length . T.takeWhile isSpace +-- TODO: This doesn't seem to handle qualified imports properly: +-- +-- plugins/hls-refactor-plugin/test/Main.hs:4011: +-- CodeAction with title "Replace _toException with E.toException" not found in +-- [..., "Replace _toException with toException", ...] printErr :: SDoc -> T.Text printErr = unescape From f08d3b567d5fa92cba798facd0f8d0f0505f8ddb Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 19 Aug 2025 19:59:03 -0400 Subject: [PATCH 3/3] fix: Run pre-commit fixes --- .../IDE/Plugin/Plugins/FillHole.hs | 44 ++++++++++--------- 1 file changed, 23 insertions(+), 21 deletions(-) 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 a2c041e2fa..ed201daa65 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 @@ -3,28 +3,30 @@ module Development.IDE.Plugin.Plugins.FillHole ) where import Control.Lens -import Control.Monad (guard) +import Control.Monad (guard) import Data.Char -import qualified Data.Text as T -import Development.IDE (FileDiagnostic, - fdLspDiagnosticL, - printOutputable) -import Development.IDE.GHC.Compat (defaultSDocContext, - renderWithContext, SDoc) -import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (..), - _TcRnMessageWithCtx, - _TcRnMessageWithInfo, - hole_occ, - msgEnvelopeErrorL) -import Development.IDE.Types.Diagnostics (_SomeStructuredMessage, - fdStructuredMessageL) -import GHC.Tc.Errors.Types (ErrInfo (..)) -import Ide.PluginUtils (unescape) -import Language.LSP.Protocol.Lens (HasRange (..)) -import Language.LSP.Protocol.Types (TextEdit (..)) -import Text.Regex.TDFA (MatchResult (..), (=~)) -import GHC.Utils.Outputable (SDocContext(..)) -import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + fdLspDiagnosticL, + printOutputable) +import Development.IDE.GHC.Compat (SDoc, + defaultSDocContext, + renderWithContext) +import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (..), + _TcRnMessageWithCtx, + _TcRnMessageWithInfo, + hole_occ, + msgEnvelopeErrorL) +import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage, + fdStructuredMessageL) +import GHC.Tc.Errors.Types (ErrInfo (..)) +import GHC.Utils.Outputable (SDocContext (..)) +import Ide.PluginUtils (unescape) +import Language.LSP.Protocol.Lens (HasRange (..)) +import Language.LSP.Protocol.Types (TextEdit (..)) +import Text.Regex.TDFA (MatchResult (..), + (=~)) suggestFillHole :: FileDiagnostic -> [(T.Text, TextEdit)] suggestFillHole diag