Skip to content

Commit a76b094

Browse files
vidit-odvidit-od
committed
Migrate Refactor plugin
1 parent d82537c commit a76b094

7 files changed

Lines changed: 401 additions & 241 deletions

File tree

‎ghcide/src/Development/IDE/GHC/Compat/Error.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ module Development.IDE.GHC.Compat.Error (
2929
_GhcDriverMessage,
3030
_ReportHoleError,
3131
_TcRnIllegalWildcardInType,
32+
_TcRnNotInScope,
3233
_TcRnPartialTypeSignatures,
3334
_TcRnMissingSignature,
3435
_TcRnSolverReport,

‎ghcide/src/Development/IDE/Types/Diagnostics.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,6 @@ module Development.IDE.Types.Diagnostics (
2929
attachReason,
3030
attachedReason) where
3131

32-
import Control.Applicative ((<|>))
3332
import Control.DeepSeq
3433
import Control.Lens
3534
import qualified Data.Aeson as JSON

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs‎

Lines changed: 173 additions & 153 deletions
Large diffs are not rendered by default.

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs‎

Lines changed: 12 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import GHC.Parser.Annotation (TokenLocation (..))
3232
#if !MIN_VERSION_ghc(9,9,0)
3333
import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst)
3434
import Development.IDE.GHC.ExactPrint (genAnchor1)
35+
import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic))
3536
import GHC.Parser.Annotation (EpAnn (..),
3637
SrcSpanAnn' (..),
3738
emptyComments)
@@ -66,13 +67,13 @@ type HsArrow pass = HsMultAnn pass
6667
-- foo :: a -> b -> c -> d
6768
-- foo a b = \c -> ...
6869
-- In this case a new argument would have to add its type between b and c in the signature.
69-
plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])]
70-
plugin parsedModule Diagnostic {_message, _range}
71-
| Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ
72-
| Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ)
70+
plugin :: ParsedModule -> FileDiagnostic -> Either PluginError [(T.Text, [TextEdit])]
71+
plugin parsedModule fd
72+
| Just (name, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range name typ
73+
| Just (name, typ) <- matchFoundHoleIncludeUnderscore fd = addArgumentAction parsedModule _range name (Just typ)
7374
| otherwise = pure []
7475
where
75-
message = unifySpaces _message
76+
Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic
7677

7778
-- Given a name for the new binding, add a new pattern to the match in the last position,
7879
-- returning how many patterns there were in this match prior to the transformation:
@@ -155,11 +156,14 @@ addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do
155156
Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'
156157
Nothing -> pure moduleSrc'
157158
let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource)
158-
pure [("Add argument ‘" <> name <> "’ to function", diff)]
159+
pure [("Add argument ‘" <> definedName <> "’ to function", diff)]
159160
where
160161
addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg
161-
addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name
162-
162+
addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches definedName
163+
definedName =
164+
case T.stripPrefix "_" name of
165+
Just n -> n
166+
Nothing -> name
163167
spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range)
164168

165169
-- Transform an LHsType into a list of arguments and return type, to make transformations easier.

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs‎

Lines changed: 69 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,31 @@
1+
{-# LANGUAGE CPP #-}
2+
13
module Development.IDE.Plugin.Plugins.Diagnostic (
24
matchVariableNotInScope,
35
matchRegexUnifySpaces,
46
unifySpaces,
57
matchFoundHole,
68
matchFoundHoleIncludeUnderscore,
9+
diagReportHoleError
710
)
811
where
912

10-
import Data.Bifunctor (Bifunctor (..))
11-
import qualified Data.Text as T
12-
import Text.Regex.TDFA ((=~~))
13+
import Control.Lens
14+
import Data.Bifunctor (Bifunctor (..))
15+
import qualified Data.Text as T
16+
import Development.IDE (printOutputable)
17+
import Development.IDE.GHC.Compat (RdrName)
18+
import Development.IDE.GHC.Compat.Error (Hole, _ReportHoleError,
19+
_TcRnMessage,
20+
_TcRnNotInScope,
21+
_TcRnSolverReport, hole_occ,
22+
hole_ty, msgEnvelopeErrorL,
23+
reportContentL)
24+
import Development.IDE.Types.Diagnostics (FileDiagnostic,
25+
_SomeStructuredMessage,
26+
fdStructuredMessageL)
27+
import GHC.Tc.Errors.Types (NotInScopeError)
28+
import Text.Regex.TDFA ((=~~))
1329

1430
unifySpaces :: T.Text -> T.Text
1531
unifySpaces = T.unwords . T.words
@@ -27,33 +43,53 @@ matchRegex message regex = case message =~~ regex of
2743
matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
2844
matchRegexUnifySpaces message = matchRegex (unifySpaces message)
2945

30-
matchFoundHole :: T.Text -> Maybe (T.Text, T.Text)
31-
matchFoundHole message
32-
| Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" =
33-
Just (name, typ)
34-
| otherwise = Nothing
35-
36-
matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text)
37-
matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message
38-
39-
matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)
40-
matchVariableNotInScope message
41-
-- * Variable not in scope:
42-
-- suggestAcion :: Maybe T.Text -> Range -> Range
43-
-- * Variable not in scope:
44-
-- suggestAcion
45-
| Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ)
46-
| Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing)
47-
| otherwise = Nothing
48-
where
49-
matchVariableNotInScopeTyped message
50-
| Just [name, typ0] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
51-
, -- When some name in scope is similar to not-in-scope variable, the type is followed by
52-
-- "Suggested fix: Perhaps use ..."
53-
typ:_ <- T.splitOn " Suggested fix:" typ0 =
54-
Just (name, typ)
55-
| otherwise = Nothing
56-
matchVariableNotInScopeUntyped message
57-
| Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" =
58-
Just name
59-
| otherwise = Nothing
46+
matchFoundHole :: FileDiagnostic -> Maybe (T.Text, T.Text)
47+
matchFoundHole fd = do
48+
hole <- diagReportHoleError fd
49+
Just (printOutputable (hole_occ hole), printOutputable (hole_ty hole))
50+
51+
matchFoundHoleIncludeUnderscore :: FileDiagnostic -> Maybe (T.Text, T.Text)
52+
matchFoundHoleIncludeUnderscore fd = first ("_" <>) <$> matchFoundHole fd
53+
54+
matchVariableNotInScope :: FileDiagnostic -> Maybe (T.Text, Maybe T.Text)
55+
matchVariableNotInScope fd = do
56+
(rdrName, _) <- diagReportNotInScope fd
57+
Just (printOutputable rdrName, Nothing)
58+
59+
-- | Extract the 'Hole' out of a 'FileDiagnostic'
60+
diagReportHoleError :: FileDiagnostic -> Maybe Hole
61+
diagReportHoleError diag = do
62+
solverReport <-
63+
diag
64+
^? fdStructuredMessageL
65+
. _SomeStructuredMessage
66+
. msgEnvelopeErrorL
67+
. _TcRnMessage
68+
. _TcRnSolverReport
69+
. _1
70+
(hole, _) <- solverReport ^? reportContentL . _ReportHoleError
71+
72+
Just hole
73+
74+
-- | Extract the 'NotInScopeError' and the corresponding 'RdrName' from a 'FileDiagnostic'
75+
-- if it represents a not-in-scope error.
76+
diagReportNotInScope :: FileDiagnostic -> Maybe (RdrName, NotInScopeError)
77+
diagReportNotInScope diag = do
78+
#if MIN_VERSION_ghc(9,13,0)
79+
(err, rdrName) <-
80+
diag
81+
^? fdStructuredMessageL
82+
. _SomeStructuredMessage
83+
. msgEnvelopeErrorL
84+
. _TcRnMessage
85+
. _TcRnNotInScope
86+
#else
87+
(err, rdrName, _, _) <-
88+
diag
89+
^? fdStructuredMessageL
90+
. _SomeStructuredMessage
91+
. msgEnvelopeErrorL
92+
. _TcRnMessage
93+
. _TcRnNotInScope
94+
#endif
95+
Just (rdrName, err)

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs‎

Lines changed: 131 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -2,42 +2,156 @@ module Development.IDE.Plugin.Plugins.FillHole
22
( suggestFillHole
33
) where
44

5+
import Control.Lens ((^.), (^?))
56
import Control.Monad (guard)
67
import Data.Char
8+
import qualified Data.HashSet as Set
79
import qualified Data.Text as T
8-
import Development.IDE.Plugin.Plugins.Diagnostic
9-
import Language.LSP.Protocol.Types (Diagnostic (..),
10-
TextEdit (TextEdit))
10+
import Development.IDE (FileDiagnostic,
11+
fdLspDiagnosticL,
12+
printOutputable)
13+
import Development.IDE.GHC.Compat (ParsedModule, SDoc,
14+
defaultSDocContext,
15+
hsmodImports,
16+
ideclAs, ideclName,
17+
ideclQualified,
18+
lookupOccEnv,
19+
moduleNameString,
20+
pm_parsed_source,
21+
renderWithContext,
22+
unLoc)
23+
import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (TcRnMessageDetailed),
24+
_TcRnMessageWithCtx,
25+
_TcRnMessageWithInfo,
26+
hole_occ,
27+
msgEnvelopeErrorL)
28+
import Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError)
29+
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage,
30+
fdStructuredMessageL)
31+
import Development.IDE.Types.Exports (ExportsMap (..),
32+
mkVarOrDataOcc,
33+
moduleNameText)
34+
import GHC.Tc.Errors.Types (ErrInfo (ErrInfo))
35+
import Ide.PluginUtils (unescape)
36+
import Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..))
37+
import Language.LSP.Protocol.Lens (HasRange (..))
38+
import Language.LSP.Protocol.Types (TextEdit (TextEdit))
1139
import Text.Regex.TDFA (MatchResult (..),
1240
(=~))
1341

14-
suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]
15-
suggestFillHole Diagnostic{_range=_range,..}
16-
| Just holeName <- extractHoleName _message
17-
, (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =
18-
let isInfixHole = _message =~ addBackticks holeName :: Bool in
42+
suggestFillHole :: ExportsMap -> ParsedModule -> FileDiagnostic -> [(T.Text, TextEdit)]
43+
suggestFillHole exportsMap pm diag
44+
| Just holeName <- extractHoleName diag
45+
, Just (ErrInfo ctx suppl) <- extractErrInfo diag
46+
, (holeFits, refFits) <- processHoleSuggestions $ T.lines (printErr suppl) =
47+
let isInfixHole = printErr ctx =~ addBackticks holeName :: Bool in
1948
map (proposeHoleFit holeName False isInfixHole) holeFits
2049
++ map (proposeHoleFit holeName True isInfixHole) refFits
2150
| otherwise = []
2251
where
23-
extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
52+
qualify = qualifyFit exportsMap pm
53+
54+
extractHoleName :: FileDiagnostic -> Maybe T.Text
55+
extractHoleName d = do
56+
hole <- diagReportHoleError d
57+
Just $ printOutputable (hole_occ hole)
58+
59+
extractErrInfo :: FileDiagnostic -> Maybe ErrInfo
60+
extractErrInfo d = do
61+
(_, TcRnMessageDetailed errInfo _) <-
62+
d ^? fdStructuredMessageL
63+
. _SomeStructuredMessage
64+
. msgEnvelopeErrorL
65+
. _TcRnMessageWithCtx
66+
. _TcRnMessageWithInfo
67+
Just errInfo
68+
69+
printErr :: SDoc -> T.Text
70+
printErr = unescape . T.pack . renderWithContext defaultSDocContext
71+
72+
addBackticks :: T.Text -> T.Text
2473
addBackticks text = "`" <> text <> "`"
74+
75+
addParens :: T.Text -> T.Text
2576
addParens text = "(" <> text <> ")"
77+
78+
proposeHoleFit :: T.Text -> Bool -> Bool -> T.Text -> (T.Text, TextEdit)
2679
proposeHoleFit holeName parenthise isInfixHole name =
2780
case T.uncons name of
2881
Nothing -> error "impossible: empty name provided by ghc"
2982
Just (firstChr, _) ->
30-
let isInfixOperator = firstChr == '('
31-
name' = getOperatorNotation isInfixHole isInfixOperator name in
32-
( "Replace " <> holeName <> " with " <> name
33-
, TextEdit _range (if parenthise then addParens name' else name')
34-
)
83+
let cleanName = qualify (stripUnique name)
84+
isInfixOperator = firstChr == '('
85+
name' = getOperatorNotation isInfixHole isInfixOperator cleanName
86+
replacement = if parenthise then addParens name' else name'
87+
in
88+
( "Replace " <> holeName <> " with " <> cleanName
89+
, TextEdit (diag ^. fdLspDiagnosticL . range) replacement
90+
)
91+
92+
getOperatorNotation :: Bool -> Bool -> T.Text -> T.Text
3593
getOperatorNotation True False name = addBackticks name
3694
getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name)
3795
getOperatorNotation _isInfixHole _isInfixOperator name = name
38-
headOrThrow msg = \case
39-
[] -> error msg
40-
(x:_) -> x
96+
97+
stripUnique :: T.Text -> T.Text
98+
stripUnique t =
99+
case T.breakOnEnd "_" t of
100+
(prefix, suffix)
101+
| T.null prefix -> t
102+
| T.null suffix -> t
103+
| not (T.all isAlphaNum suffix) -> t
104+
| otherwise -> T.dropEnd (T.length suffix + 1) t
105+
106+
-- | Given the exports map, parsed module (for its imports), and a hole fit
107+
-- name like "toException", return the qualified version like "E.toException"
108+
-- if a qualifying import exists, otherwise return the name as it is.
109+
qualifyFit :: ExportsMap -> ParsedModule -> T.Text -> T.Text
110+
qualifyFit exportsMap pm fitName =
111+
case findQualifier of
112+
Nothing -> fitName
113+
Just qualifier -> qualifier <> "." <> fitName
114+
where
115+
-- All modules that export this name
116+
exportingModules :: [T.Text]
117+
exportingModules =
118+
let occ = mkVarOrDataOcc fitName
119+
identSet = lookupOccEnv (getExportsMap exportsMap) occ
120+
idents = maybe [] Set.toList identSet
121+
in map moduleNameText idents
122+
123+
-- All qualified imports from this file: (moduleName, qualifier)
124+
qualifiedImports :: [(T.Text, T.Text)]
125+
qualifiedImports =
126+
let imports = hsmodImports . unLoc . pm_parsed_source $ pm
127+
in [ (modName decl, qualifier decl)
128+
| i <- imports
129+
, let decl = unLoc i
130+
, isQualified decl
131+
]
132+
133+
isQualified decl = ideclQualified decl `elem` [QualifiedPre, QualifiedPost]
134+
135+
modName decl =
136+
T.pack . moduleNameString . unLoc . ideclName $ decl
137+
138+
qualifier decl =
139+
case ideclAs decl of
140+
Just alias -> T.pack . moduleNameString . unLoc $ alias
141+
Nothing -> modName decl
142+
143+
-- Find first qualified import whose module is in the exporting modules list
144+
findQualifier :: Maybe T.Text
145+
findQualifier =
146+
let exportingSet = exportingModules
147+
in fmap snd
148+
. safeHead
149+
. filter (\(modN, _) -> modN `elem` exportingSet)
150+
$ qualifiedImports
151+
152+
safeHead [] = Nothing
153+
safeHead (x:_) = Just x
154+
41155

42156
processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])
43157
processHoleSuggestions mm = (holeSuggestions, refSuggestions)

0 commit comments

Comments
 (0)