Skip to content

Commit 2c98040

Browse files
vidit-odvidit-od
committed
Fix builds and Regex diagnostics for 9.6
1 parent a76b094 commit 2c98040

File tree

3 files changed

+115
-35
lines changed

3 files changed

+115
-35
lines changed

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

Lines changed: 98 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -53,10 +53,7 @@ import Development.IDE.GHC.Compat hiding
5353
import Development.IDE.GHC.Compat.Error (TcRnMessage (..),
5454
_TcRnMessage,
5555
msgEnvelopeErrorL)
56-
import GHC.Tc.Errors.Types (ShadowedNameProvenance (..),
57-
UnusedImportName (..),
58-
UnusedImportReason (..),
59-
UnusedNameProv (..))
56+
import GHC.Tc.Errors.Types (ShadowedNameProvenance (..))
6057
#if !MIN_VERSION_ghc(9,11,0)
6158
import Development.IDE.GHC.Compat.Util
6259
#endif
@@ -136,7 +133,11 @@ import GHC (AnnsModule (
136133
EpaLocation' (..),
137134
HasLoc (..))
138135
#endif
139-
136+
#if MIN_VERSION_ghc(9,7,0)
137+
import GHC.Tc.Errors.Types (UnusedImportName (..),
138+
UnusedImportReason (..),
139+
UnusedNameProv (..))
140+
#endif
140141

141142
-------------------------------------------------------------------------------------------------
142143

@@ -393,10 +394,16 @@ suggestHideShadow ps fileContents mTcM mHar fd =
393394

394395
greModsAndSpans :: GlobalRdrElt -> [(T.Text, RealSrcSpan)]
395396
greModsAndSpans gre =
396-
[ (T.pack $ moduleNameString $ moduleName $ is_mod (is_decl imp), sp)
397-
| imp <- gre_imp gre
398-
, RealSrcSpan sp _ <- [is_dloc (is_decl imp)]
399-
]
397+
[ (T.pack $ moduleNameString modName, sp)
398+
| imp <- gre_imp gre
399+
, let modName =
400+
#if MIN_VERSION_ghc(9,7,0)
401+
moduleName $ is_mod (is_decl imp)
402+
#else
403+
is_mod (is_decl imp)
404+
#endif
405+
, RealSrcSpan sp _ <- [is_dloc (is_decl imp)]
406+
]
400407

401408
suggests :: T.Text -> RealSrcSpan -> [(T.Text, [Either TextEdit Rewrite])]
402409
suggests modName s'
@@ -462,8 +469,47 @@ isUnusedImportedId
462469
maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs
463470
| otherwise = False
464471

465-
suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
466-
suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents fd =
472+
suggestRemoveRedundantImportBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
473+
suggestRemoveRedundantImportBinding pm contents fd =
474+
#if MIN_VERSION_ghc(9,7,0)
475+
suggestRemoveRedundantImportStructured pm contents fd
476+
#else
477+
suggestRemoveRedundantImportRegex pm contents (fdLspDiagnostic fd)
478+
#endif
479+
480+
#if !MIN_VERSION_ghc(9,7,0)
481+
suggestRemoveRedundantImportRegex :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
482+
suggestRemoveRedundantImportRegex ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
483+
-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
484+
| Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
485+
, Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports
486+
, Just c <- contents
487+
, ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings >>= trySplitIntoOriginalAndRecordField)
488+
, ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)
489+
, not (null ranges')
490+
= [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
491+
492+
-- File.hs:16:1: warning:
493+
-- The import of `Data.List' is redundant
494+
-- except perhaps to import instances from `Data.List'
495+
-- To import instances alone, use: import Data.List()
496+
| _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
497+
= [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
498+
| otherwise = []
499+
where
500+
-- In case of an unused record field import, the binding from the message will not match any import directly
501+
-- In this case, we try if we can additionally extract a record field name
502+
-- Example: The import of ‘B(b2)’ from module ‘ModuleB’ is redundant
503+
trySplitIntoOriginalAndRecordField :: T.Text -> [T.Text]
504+
trySplitIntoOriginalAndRecordField binding =
505+
case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of
506+
Just [_, fields] -> [binding, fields]
507+
_ -> [binding]
508+
#endif
509+
510+
#if MIN_VERSION_ghc(9,7,0)
511+
suggestRemoveRedundantImportStructured :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
512+
suggestRemoveRedundantImportStructured ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents fd =
467513
case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
468514
Just (TcRnUnusedImport impDecl reason) ->
469515
let wantedModule = moduleNameString $ unLoc $ ideclName impDecl
@@ -502,6 +548,7 @@ unusedImportNameText (UnusedImportNameRecField parent occName) =
502548
case parent of
503549
ParentIs name -> T.pack (getOccString name) <> "(" <> T.pack (occNameString occName) <> ")"
504550
NoParent -> T.pack (occNameString occName) -- Fallback safety (unlikely)
551+
#endif
505552

506553
diagInRange :: Diagnostic -> Range -> Bool
507554
diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange
@@ -519,7 +566,7 @@ diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange
519566
caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction]
520567
caRemoveRedundantImports m contents allDiags contextRange uri
521568
| Just pm <- m,
522-
r <- join $ map (\fd -> let d = fdLspDiagnostic fd in repeat d `zip` suggestRemoveRedundantImport pm contents fd) allDiags,
569+
r <- join $ map (\fd -> let d = fdLspDiagnostic fd in repeat d `zip` suggestRemoveRedundantImportBinding pm contents fd) allDiags,
523570
allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],
524571
caRemoveAll <- removeAll allEdits,
525572
ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange],
@@ -621,16 +668,32 @@ suggestRemoveRedundantExport _ _ = Nothing
621668

622669
suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
623670
suggestDeleteUnusedBinding pm contents fd =
624-
case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
625-
Just (TcRnUnusedName occName prov)
626-
| isLocalUnusedName prov -> suggestDeleteUnusedBindingByName pm contents (T.pack $ occNameString occName) (fdLspDiagnostic fd)
627-
_ -> []
671+
#if MIN_VERSION_ghc(9,7,0)
672+
suggestDeleteUnusedBindingStructured pm contents fd
673+
#else
674+
suggestDeleteUnusedBindingRegex pm contents (fdLspDiagnostic fd)
675+
#endif
676+
677+
#if MIN_VERSION_ghc(9,7,0)
678+
suggestDeleteUnusedBindingStructured :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
679+
suggestDeleteUnusedBindingStructured pm contents fd
680+
| Just (TcRnUnusedName occName prov) <- fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
681+
, isLocalUnusedName prov
682+
= suggestDeleteUnusedBindingByName pm contents (T.pack $ occNameString occName) (fdLspDiagnostic fd)
683+
| otherwise = []
628684

629685
isLocalUnusedName :: UnusedNameProv -> Bool
630686
isLocalUnusedName UnusedNameTopDecl = True
631687
isLocalUnusedName UnusedNameLocalBind = True
632688
isLocalUnusedName UnusedNameMatch = True
633689
isLocalUnusedName _ = False
690+
#else
691+
suggestDeleteUnusedBindingRegex :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
692+
suggestDeleteUnusedBindingRegex pm contents diag@Diagnostic{_message}
693+
| Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"
694+
= suggestDeleteUnusedBindingByName pm contents name diag
695+
| otherwise = []
696+
#endif
634697

635698
suggestDeleteUnusedBindingByName :: ParsedModule -> Maybe T.Text -> T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
636699
suggestDeleteUnusedBindingByName ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} contents name Diagnostic{_range=_range}
@@ -754,13 +817,25 @@ getLocatedRange = srcSpanToRange . getLoc
754817

755818
suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit)
756819
suggestExportUnusedTopBinding srcOpt pm fd =
757-
-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’
758-
-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’
759-
-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’
760-
case fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
761-
Just (TcRnUnusedName occName UnusedNameTopDecl) ->
762-
suggestExportUnusedTopBindingByName srcOpt pm (T.pack $ occNameString occName) (fdLspDiagnostic fd)
763-
_ -> Nothing
820+
#if MIN_VERSION_ghc(9,7,0)
821+
suggestExportUnusedTopBindingStructured srcOpt pm fd
822+
#else
823+
suggestExportUnusedTopBindingRegex srcOpt pm (fdLspDiagnostic fd)
824+
#endif
825+
826+
#if MIN_VERSION_ghc(9,7,0)
827+
suggestExportUnusedTopBindingStructured :: Maybe T.Text -> ParsedModule -> FileDiagnostic -> Maybe (T.Text, TextEdit)
828+
suggestExportUnusedTopBindingStructured srcOpt pm fd
829+
| Just (TcRnUnusedName occName UnusedNameTopDecl) <- fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
830+
= suggestExportUnusedTopBindingByName srcOpt pm (T.pack $ occNameString occName) (fdLspDiagnostic fd)
831+
| otherwise = Nothing
832+
#else
833+
suggestExportUnusedTopBindingRegex :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (T.Text, TextEdit)
834+
suggestExportUnusedTopBindingRegex srcOpt pm diag@Diagnostic{_message}
835+
| Just [_, name] <- matchRegexUnifySpaces _message ".*Defined but not used: (type constructor or class |data constructor )?‘([^ ]+)’"
836+
= suggestExportUnusedTopBindingByName srcOpt pm name diag
837+
| otherwise = Nothing
838+
#endif
764839

765840
suggestExportUnusedTopBindingByName :: Maybe T.Text -> ParsedModule -> T.Text -> Diagnostic -> Maybe (T.Text, TextEdit)
766841
suggestExportUnusedTopBindingByName srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} name Diagnostic{..}

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Development.IDE.GHC.ExactPrint (modifyMgMatchesT',
1212
modifySigWithM,
1313
modifySmallestDeclWithM)
1414
import Development.IDE.Plugin.Plugins.Diagnostic
15+
import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic))
1516
import GHC.Parser.Annotation (SrcSpanAnnA,
1617
SrcSpanAnnN, noAnn)
1718
import Ide.Plugin.Error (PluginError (PluginInternalError))
@@ -32,7 +33,6 @@ import GHC.Parser.Annotation (TokenLocation (..))
3233
#if !MIN_VERSION_ghc(9,9,0)
3334
import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst)
3435
import Development.IDE.GHC.ExactPrint (genAnchor1)
35-
import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic))
3636
import GHC.Parser.Annotation (EpAnn (..),
3737
SrcSpanAnn' (..),
3838
emptyComments)

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

Lines changed: 16 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
module Development.IDE.Plugin.Plugins.FillHole
23
( suggestFillHole
34
) where
@@ -8,17 +9,16 @@ import Data.Char
89
import qualified Data.HashSet as Set
910
import qualified Data.Text as T
1011
import Development.IDE (FileDiagnostic,
12+
_message,
1113
fdLspDiagnosticL,
1214
printOutputable)
13-
import Development.IDE.GHC.Compat (ParsedModule, SDoc,
14-
defaultSDocContext,
15+
import Development.IDE.GHC.Compat (ParsedModule,
1516
hsmodImports,
1617
ideclAs, ideclName,
1718
ideclQualified,
1819
lookupOccEnv,
1920
moduleNameString,
2021
pm_parsed_source,
21-
renderWithContext,
2222
unLoc)
2323
import Development.IDE.GHC.Compat.Error (TcRnMessageDetailed (TcRnMessageDetailed),
2424
_TcRnMessageWithCtx,
@@ -31,8 +31,7 @@ import Development.IDE.Types.Diagnostics (_SomeStructuredMessa
3131
import Development.IDE.Types.Exports (ExportsMap (..),
3232
mkVarOrDataOcc,
3333
moduleNameText)
34-
import GHC.Tc.Errors.Types (ErrInfo (ErrInfo))
35-
import Ide.PluginUtils (unescape)
34+
import GHC.Tc.Errors.Types (ErrInfo)
3635
import Language.Haskell.Syntax.ImpExp (ImportDeclQualifiedStyle (..))
3736
import Language.LSP.Protocol.Lens (HasRange (..))
3837
import Language.LSP.Protocol.Types (TextEdit (TextEdit))
@@ -42,11 +41,20 @@ import Text.Regex.TDFA (MatchResult (..),
4241
suggestFillHole :: ExportsMap -> ParsedModule -> FileDiagnostic -> [(T.Text, TextEdit)]
4342
suggestFillHole exportsMap pm diag
4443
| Just holeName <- extractHoleName diag
44+
#if MIN_VERSION_ghc(9,13,0)
45+
, Just _errInfo <- extractErrInfo diag
46+
, let supplText = _message (diag ^. fdLspDiagnosticL)
47+
, let ctxText = supplText
48+
#else
4549
, Just (ErrInfo ctx suppl) <- extractErrInfo diag
46-
, (holeFits, refFits) <- processHoleSuggestions $ T.lines (printErr suppl) =
47-
let isInfixHole = printErr ctx =~ addBackticks holeName :: Bool in
50+
, let ctxText = printOutputable ctx
51+
, let supplText = printOutputable suppl
52+
#endif
53+
, let (holeFits, refFits) = processHoleSuggestions (T.lines supplText)
54+
, let isInfixHole = ctxText =~ addBackticks holeName :: Bool =
4855
map (proposeHoleFit holeName False isInfixHole) holeFits
49-
++ map (proposeHoleFit holeName True isInfixHole) refFits
56+
++
57+
map (proposeHoleFit holeName True isInfixHole) refFits
5058
| otherwise = []
5159
where
5260
qualify = qualifyFit exportsMap pm
@@ -66,9 +74,6 @@ suggestFillHole exportsMap pm diag
6674
. _TcRnMessageWithInfo
6775
Just errInfo
6876

69-
printErr :: SDoc -> T.Text
70-
printErr = unescape . T.pack . renderWithContext defaultSDocContext
71-
7277
addBackticks :: T.Text -> T.Text
7378
addBackticks text = "`" <> text <> "`"
7479

0 commit comments

Comments
 (0)