Skip to content

WIP: Use Structured Diagnostics for Typed Holes #4695

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 3 commits into
base: master
Choose a base branch
from
Draft

WIP: Use Structured Diagnostics for Typed Holes #4695

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
be251f4
Use structured diagnostics for typed hole suggestions
sgillespie Aug 19, 2025
a6d6113
doc: Add debugging note
sgillespie Aug 19, 2025
f08d3b5
fix: Run pre-commit fixes
sgillespie Aug 19, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
31 changes: 28 additions & 3 deletions plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
99 changes: 72 additions & 27 deletions plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,25 +2,42 @@ module Development.IDE.Plugin.Plugins.FillHole
( suggestFillHole
) where

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 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 :: 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 =
Expand All @@ -30,14 +47,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)
Expand Down Expand Up @@ -76,22 +109,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]]
Expand All @@ -103,3 +133,18 @@ 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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I can't seem to find any combination of SDocContext options that will result in E.toException (that is, with import qualified Control.Exception as E.

printErr =
unescape
. T.pack
. renderWithContext
( defaultSDocContext
{ sdocCanUseUnicode = False
, sdocSuppressUniques = True
}
)
36 changes: 11 additions & 25 deletions plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 {..}}
Expand All @@ -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
Expand Down
26 changes: 26 additions & 0 deletions plugins/hls-refactor-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading