Migrate hls-refactor-plugin to use structured diagnostics

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

@@ -22,14 +22,15 @@
                                                                     (&&&),
                                                                     (>>>))
 import           Control.Concurrent.STM.Stats                      (atomically)
+import           Control.Lens                                      hiding (List,
+                                                                    uncons, use)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Except                        (ExceptT (ExceptT))
 import           Control.Monad.Trans.Maybe
 import           Data.Char
 import qualified Data.DList                                        as DL
 import           Data.Function
-import           Data.Functor
 import qualified Data.HashMap.Strict                               as Map
 import qualified Data.HashSet                                      as Set
 import           Data.List.Extra
@@ -49,6 +50,9 @@
 import           Development.IDE.Core.Shake                        hiding (Log)
 import           Development.IDE.GHC.Compat                        hiding
                                                                    (ImplicitPrelude)
+import           Development.IDE.GHC.Compat.Error                  (TcRnMessage (..),
+                                                                    _TcRnMessage,
+                                                                    msgEnvelopeErrorL)
 #if !MIN_VERSION_ghc(9,11,0)
 import           Development.IDE.GHC.Compat.Util
 #endif
@@ -78,6 +82,8 @@
 import           GHC.Iface.Ext.Types                               (ContextInfo (..),
                                                                     IdentifierDetails (..))
 import qualified GHC.LanguageExtensions                            as Lang
+import           GHC.Tc.Errors.Types                               (UnusedImportName (..),
+                                                                    UnusedImportReason (..))
 import           Ide.Logger                                        hiding
                                                                    (group)
 import           Ide.PluginUtils                                   (extendToFullLines,
@@ -138,12 +144,12 @@
   contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri
   liftIO $ do
     let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
-    allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state
+    allDiags <- atomically  $ filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state
     (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile
     let
       textContents = fmap Rope.toText contents
       actions = caRemoveRedundantImports parsedModule textContents allDiags range uri
-               <> caRemoveInvalidExports parsedModule textContents allDiags range uri
+               <> caRemoveInvalidExports parsedModule textContents (fdLspDiagnostic <$> allDiags) range uri
     pure $ InL actions
 
 -------------------------------------------------------------------------------------------------
@@ -447,33 +453,28 @@
       maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs
     | otherwise = False
 
-suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
---     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
-    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
-    , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports
-    , Just c <- contents
-    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings >>= trySplitIntoOriginalAndRecordField)
+suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]
+suggestRemoveRedundantImport _ contents
+  FileDiagnostic{fdStructuredMessage,fdLspDiagnostic=Diagnostic{_range=_range}}
+    | Just (TcRnUnusedImport impDecl (UnusedImportSome names)) <- fdStructuredMessage ^?  _SomeStructuredMessage. msgEnvelopeErrorL . _TcRnMessage
+      , Just c <- contents
+      , let bindings = names >>= bindingsInImp
+      , ranges <- map (rangesForBindingImport impDecl . T.unpack) bindings
     , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)
     , not (null ranges')
-    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
-
--- File.hs:16:1: warning:
---     The import of `Data.List' is redundant
---       except perhaps to import instances from `Data.List'
---     To import instances alone, use: import Data.List()
-    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
-        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
+      = [( "Remove " <> T.intercalate ", " (pprBinding <$> names) <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
+    | Just (TcRnUnusedImport _ UnusedImportNone) <- fdStructuredMessage ^?  _SomeStructuredMessage. msgEnvelopeErrorL . _TcRnMessage =
+      [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
     | otherwise = []
     where
-      -- In case of an unused record field import, the binding from the message will not match any import directly
-      -- In this case, we try if we can additionally extract a record field name
-      -- Example: The import of ‘B(b2)’ from module ‘ModuleB’ is redundant
-      trySplitIntoOriginalAndRecordField :: T.Text -> [T.Text]
-      trySplitIntoOriginalAndRecordField binding =
-        case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of
-          Just [_, fields] -> [binding, fields]
-          _                -> [binding]
+      bindingsInImp ::UnusedImportName -> [T.Text]
+      bindingsInImp (UnusedImportNameRecField NoParent name) = [printOutputable name]
+      bindingsInImp b@(UnusedImportNameRecField (ParentIs _) field) = [pprBinding b,printOutputable field]
+      bindingsInImp (UnusedImportNameRegular name) = [printOutputable name]
+      pprBinding ::UnusedImportName -> T.Text
+      pprBinding (UnusedImportNameRecField NoParent name) = printOutputable $ occName name
+      pprBinding (UnusedImportNameRecField (ParentIs parent) field) = printOutputable parent <> "("<> printOutputable  field <> ")"
+      pprBinding (UnusedImportNameRegular name) = printOutputable name
 
 diagInRange :: Diagnostic -> Range -> Bool
 diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange
@@ -488,19 +489,19 @@
 -- is likely to be removed and less likely the warning will be disabled.
 -- Therefore actions to remove a single or all redundant imports should be
 -- preferred, so that the client can prioritize them higher.
-caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction]
+caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction]
 caRemoveRedundantImports m contents allDiags contextRange uri
   | Just pm <- m,
     r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags,
     allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],
     caRemoveAll <- removeAll allEdits,
-    ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange],
+    ctxEdits <- [ x | x@(d, _) <- r, fdLspDiagnostic d `diagInRange` contextRange],
     not $ null ctxEdits,
     caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits
       = caRemoveCtx ++ [caRemoveAll]
   | otherwise = []
   where
-    removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [diagnostic] WorkspaceEdit{..} where
+    removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [fdLspDiagnostic diagnostic] WorkspaceEdit{..} where
         _changes = Just $ M.singleton uri tedit
         _documentChanges = Nothing
         _changeAnnotations = Nothing
@@ -1946,7 +1947,7 @@
       linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
 
 -- | Returns the ranges for a binding in an import declaration
-rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]
+rangesForBindingImport :: ImportDecl GhcRn -> String -> [Range]
 rangesForBindingImport ImportDecl{
   ideclImportList = Just (Exactly, L _ lies)
   } b =
@@ -1988,7 +1989,7 @@
           [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']
     ranges' _ = []
 
-rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
+rangesForBinding' :: String -> LIE GhcRn -> [SrcSpan]
 #if MIN_VERSION_ghc(9,9,0)
 rangesForBinding' b (L (locA -> l) (IEVar _ nm _))
 #else