Migrate HLS-refactor-plugin to use Structured Diagnostic

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

@@ -29,6 +29,7 @@ module Development.IDE.GHC.Compat.Error (
   _GhcDriverMessage,
   _ReportHoleError,
   _TcRnIllegalWildcardInType,
+  _TcRnNotInScope,
   _TcRnPartialTypeSignatures,
   _TcRnMissingSignature,
   _TcRnSolverReport,

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

@@ -29,7 +29,6 @@ module Development.IDE.Types.Diagnostics (
   attachReason,
   attachedReason) where
 
-import           Control.Applicative            ((<|>))
 import           Control.DeepSeq
 import           Control.Lens
 import qualified Data.Aeson                     as JSON

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

@@ -12,6 +12,7 @@ import           Development.IDE.GHC.ExactPrint            (modifyMgMatchesT',
                                                             modifySigWithM,
                                                             modifySmallestDeclWithM)
 import           Development.IDE.Plugin.Plugins.Diagnostic
+import           Development.IDE.Types.Diagnostics         (FileDiagnostic (fdLspDiagnostic))
 import           GHC.Parser.Annotation                     (SrcSpanAnnA,
                                                             SrcSpanAnnN, noAnn)
 import           Ide.Plugin.Error                          (PluginError (PluginInternalError))
@@ -66,13 +67,13 @@ type HsArrow pass = HsMultAnn pass
 --         foo :: a -> b -> c -> d
 --         foo a b = \c -> ...
 --      In this case a new argument would have to add its type between b and c in the signature.
-plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])]
-plugin parsedModule Diagnostic {_message, _range}
-  | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ
-  | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ)
+plugin :: ParsedModule -> FileDiagnostic -> Either PluginError [(T.Text, [TextEdit])]
+plugin parsedModule fd
+  | Just (name, typ) <- matchVariableNotInScope fd = addArgumentAction parsedModule _range name typ
+  | Just (name, typ) <- matchFoundHoleIncludeUnderscore fd = addArgumentAction parsedModule _range name (Just typ)
   | otherwise = pure []
   where
-    message = unifySpaces _message
+    Diagnostic{_message, _range} = fdLspDiagnostic fd :: Diagnostic
 
 -- Given a name for the new binding, add a new pattern to the match in the last position,
 -- returning how many patterns there were in this match prior to the transformation:
@@ -155,11 +156,14 @@ addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do
           Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'
           Nothing -> pure moduleSrc'
     let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource)
-    pure [("Add argument ‘" <> name <> "’ to function", diff)]
+    pure [("Add argument ‘" <> definedName <> "’ to function", diff)]
   where
     addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg
-    addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name
-
+    addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches definedName
+    definedName =
+      case T.stripPrefix "_" name of
+        Just n  -> n
+        Nothing -> name
     spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range)
 
 -- 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

@@ -1,15 +1,31 @@
+{-# LANGUAGE CPP #-}
+
 module Development.IDE.Plugin.Plugins.Diagnostic (
   matchVariableNotInScope,
   matchRegexUnifySpaces,
   unifySpaces,
   matchFoundHole,
   matchFoundHoleIncludeUnderscore,
+  diagReportHoleError
   )
   where
 
-import           Data.Bifunctor  (Bifunctor (..))
-import qualified Data.Text       as T
-import           Text.Regex.TDFA ((=~~))
+import           Control.Lens
+import           Data.Bifunctor                    (Bifunctor (..))
+import qualified Data.Text                         as T
+import           Development.IDE                   (printOutputable)
+import           Development.IDE.GHC.Compat        (RdrName)
+import           Development.IDE.GHC.Compat.Error  (Hole, _ReportHoleError,
+                                                    _TcRnMessage,
+                                                    _TcRnNotInScope,
+                                                    _TcRnSolverReport, hole_occ,
+                                                    hole_ty, msgEnvelopeErrorL,
+                                                    reportContentL)
+import           Development.IDE.Types.Diagnostics (FileDiagnostic,
+                                                    _SomeStructuredMessage,
+                                                    fdStructuredMessageL)
+import           GHC.Tc.Errors.Types               (NotInScopeError)
+import           Text.Regex.TDFA                   ((=~~))
 
 unifySpaces :: T.Text -> T.Text
 unifySpaces    = T.unwords . T.words
@@ -27,33 +43,53 @@ matchRegex message regex = case message =~~ regex of
 matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
 matchRegexUnifySpaces message = matchRegex (unifySpaces message)
 
-matchFoundHole :: T.Text -> Maybe (T.Text, T.Text)
-matchFoundHole message
-  | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" =
-      Just (name, typ)
-  | otherwise = Nothing
-
-matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text)
-matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message
-
-matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)
-matchVariableNotInScope message
-  --     * Variable not in scope:
-  --         suggestAcion :: Maybe T.Text -> Range -> Range
-  --     * Variable not in scope:
-  --         suggestAcion
-  | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ)
-  | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing)
-  | otherwise = Nothing
-  where
-    matchVariableNotInScopeTyped message
-      | Just [name, typ0] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
-      , -- When some name in scope is similar to not-in-scope variable, the type is followed by
-        -- "Suggested fix: Perhaps use ..."
-        typ:_ <- T.splitOn " Suggested fix:" typ0 =
-          Just (name, typ)
-      | otherwise = Nothing
-    matchVariableNotInScopeUntyped message
-      | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" =
-          Just name
-      | otherwise = Nothing
+matchFoundHole :: FileDiagnostic -> Maybe (T.Text, T.Text)
+matchFoundHole fd = do
+    hole <- diagReportHoleError fd
+    Just (printOutputable (hole_occ hole), printOutputable (hole_ty hole))
+
+matchFoundHoleIncludeUnderscore :: FileDiagnostic -> Maybe (T.Text, T.Text)
+matchFoundHoleIncludeUnderscore fd = first ("_" <>) <$> matchFoundHole fd
+
+matchVariableNotInScope :: FileDiagnostic -> Maybe (T.Text, Maybe T.Text)
+matchVariableNotInScope fd = do
+    (rdrName, _) <- diagReportNotInScope fd
+    Just (printOutputable rdrName, 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
+
+-- | Extract the 'NotInScopeError' and the corresponding 'RdrName' from a 'FileDiagnostic'
+-- if it represents a not-in-scope error.
+diagReportNotInScope :: FileDiagnostic -> Maybe (RdrName, NotInScopeError)
+diagReportNotInScope diag = do
+#if MIN_VERSION_ghc(9,13,0)
+    (err, rdrName) <-
+        diag
+            ^? fdStructuredMessageL
+                . _SomeStructuredMessage
+                . msgEnvelopeErrorL
+                . _TcRnMessage
+                . _TcRnNotInScope
+#else
+    (err, rdrName, _, _) <-
+        diag
+            ^? fdStructuredMessageL
+                . _SomeStructuredMessage
+                . msgEnvelopeErrorL
+                . _TcRnMessage
+                . _TcRnNotInScope
+#endif
+    Just (rdrName, err)

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

@@ -1,43 +1,162 @@
+{-# LANGUAGE CPP #-}
 module Development.IDE.Plugin.Plugins.FillHole
   ( suggestFillHole
   ) where
 
+import           Control.Lens                              ((^.), (^?))
 import           Control.Monad                             (guard)
 import           Data.Char
+import qualified Data.HashSet                              as Set
 import qualified Data.Text                                 as T
-import           Development.IDE.Plugin.Plugins.Diagnostic
-import           Language.LSP.Protocol.Types               (Diagnostic (..),
-                                                            TextEdit (TextEdit))
+import           Development.IDE                           (FileDiagnostic,
+                                                            _message,
+                                                            fdLspDiagnosticL,
+                                                            printOutputable)
+import           Development.IDE.GHC.Compat                (ParsedModule,
+                                                            hsmodImports,
+                                                            ideclAs, ideclName,
+                                                            ideclQualified,
+                                                            lookupOccEnv,
+                                                            moduleNameString,
+                                                            pm_parsed_source,
+                                                            unLoc)
+import           Development.IDE.GHC.Compat.Error          (TcRnMessageDetailed (TcRnMessageDetailed),
+                                                            _TcRnMessageWithCtx,
+                                                            _TcRnMessageWithInfo,
+                                                            hole_occ,
+                                                            msgEnvelopeErrorL)
+import           Development.IDE.Plugin.Plugins.Diagnostic (diagReportHoleError)
+import           Development.IDE.Types.Diagnostics         (_SomeStructuredMessage,
+                                                            fdStructuredMessageL)
+import           Development.IDE.Types.Exports             (ExportsMap (..),
+                                                            mkVarOrDataOcc,
+                                                            moduleNameText)
+import           GHC.Tc.Errors.Types                       (ErrInfo (ErrInfo))
+import           Language.Haskell.Syntax.ImpExp            (ImportDeclQualifiedStyle (..))
+import           Language.LSP.Protocol.Lens                (HasRange (..))
+import           Language.LSP.Protocol.Types               (TextEdit (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
+suggestFillHole :: ExportsMap -> ParsedModule -> FileDiagnostic -> [(T.Text, TextEdit)]
+suggestFillHole exportsMap pm diag
+    | Just holeName <- extractHoleName diag
+#if MIN_VERSION_ghc(9,13,0)
+    , Just _errInfo <- extractErrInfo diag
+    , let supplText = _message (diag ^. fdLspDiagnosticL)
+    , let ctxText = supplText
+#else
+    , Just (ErrInfo ctx suppl) <- extractErrInfo diag
+    , let ctxText = printOutputable ctx
+    , let supplText = printOutputable suppl
+#endif
+    , let (holeFits, refFits) = processHoleSuggestions (T.lines supplText)
+    , let isInfixHole = ctxText =~ addBackticks holeName :: Bool =
         map (proposeHoleFit holeName False isInfixHole) holeFits
-        ++ map (proposeHoleFit holeName True isInfixHole) refFits
+        ++
+        map (proposeHoleFit holeName True isInfixHole) refFits
     | otherwise = []
     where
-      extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
+      qualify = qualifyFit exportsMap pm
+
+      extractHoleName :: FileDiagnostic -> Maybe T.Text
+      extractHoleName d = do
+          hole <- diagReportHoleError d
+          Just $ printOutputable (hole_occ hole)
+
+      extractErrInfo :: FileDiagnostic -> Maybe ErrInfo
+      extractErrInfo d = do
+          (_, TcRnMessageDetailed errInfo _) <-
+              d ^? fdStructuredMessageL
+                 . _SomeStructuredMessage
+                 . msgEnvelopeErrorL
+                 . _TcRnMessageWithCtx
+                 . _TcRnMessageWithInfo
+          Just errInfo
+
+      addBackticks :: T.Text -> T.Text
       addBackticks text = "`" <> text <> "`"
+
+      addParens :: T.Text -> T.Text
       addParens text = "(" <> text <> ")"
+
+      proposeHoleFit :: T.Text -> Bool -> Bool -> T.Text -> (T.Text, TextEdit)
       proposeHoleFit holeName parenthise isInfixHole name =
         case T.uncons name of
           Nothing -> error "impossible: empty name provided by ghc"
           Just (firstChr, _) ->
-            let isInfixOperator = firstChr == '('
-                name' = getOperatorNotation isInfixHole isInfixOperator name in
-              ( "Replace " <> holeName <> " with " <> name
-              , TextEdit _range (if parenthise then addParens name' else name')
-              )
+            let cleanName = qualify (stripUnique name)
+                isInfixOperator = firstChr == '('
+                name' = getOperatorNotation isInfixHole isInfixOperator cleanName
+                replacement = if parenthise then addParens name' else name'
+            in
+               ( "Replace " <> holeName <> " with " <> cleanName
+               , TextEdit (diag ^. fdLspDiagnosticL . range) replacement
+               )
+
+      getOperatorNotation :: Bool -> Bool -> T.Text -> T.Text
       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
+
+      stripUnique :: T.Text -> T.Text
+      stripUnique t =
+        case T.breakOnEnd "_" t of
+          (prefix, suffix)
+            | T.null prefix -> t
+            | T.null suffix -> t
+            | not (T.all isAlphaNum suffix) -> t
+            | otherwise -> T.dropEnd (T.length suffix + 1) t
+
+-- | Given the exports map, parsed module (for its imports), and a hole fit
+-- name like "toException", return the qualified version like "E.toException"
+-- if a qualifying import exists, otherwise return the name as it is.
+qualifyFit :: ExportsMap -> ParsedModule -> T.Text -> T.Text
+qualifyFit exportsMap pm fitName =
+    case findQualifier of
+        Nothing        -> fitName
+        Just qualifier -> qualifier <> "." <> fitName
+  where
+    -- All modules that export this name
+    exportingModules :: [T.Text]
+    exportingModules =
+        let occ      = mkVarOrDataOcc fitName
+            identSet = lookupOccEnv (getExportsMap exportsMap) occ
+            idents   = maybe [] Set.toList identSet
+        in map moduleNameText idents
+
+    -- All qualified imports from this file: (moduleName, qualifier)
+    qualifiedImports :: [(T.Text, T.Text)]
+    qualifiedImports =
+        let imports = hsmodImports . unLoc . pm_parsed_source $ pm
+        in [ (modName decl, qualifier decl)
+           | i <- imports
+           , let decl = unLoc i
+           , isQualified decl
+           ]
+
+    isQualified decl = ideclQualified decl `elem` [QualifiedPre, QualifiedPost]
+
+    modName decl =
+        T.pack . moduleNameString . unLoc . ideclName $ decl
+
+    qualifier decl =
+        case ideclAs decl of
+            Just alias -> T.pack . moduleNameString . unLoc $ alias
+            Nothing    -> modName decl
+
+    -- Find first qualified import whose module is in the exporting modules list
+    findQualifier :: Maybe T.Text
+    findQualifier =
+        let exportingSet = exportingModules
+        in fmap snd
+         . safeHead
+         . filter (\(modN, _) -> modN `elem` exportingSet)
+         $ qualifiedImports
+
+    safeHead []    = Nothing
+    safeHead (x:_) = Just x
+
 
 processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])
 processHoleSuggestions mm = (holeSuggestions, refSuggestions)