fix: CodeAction respects local qualification when filling suggested constraint (#5085)

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

@@ -8,6 +8,8 @@ module Development.IDE.GHC.Compat.Outputable (
     showSDocForUser,
     ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,
     printSDocQualifiedUnsafe,
+    queryQualifyName,
+    QualifyName(..),
     printWithoutUniques,
     printWithoutUniquesOneLine,
     mkPrintUnqualifiedDefault,

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

@@ -60,6 +60,7 @@ import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.ExactPrint
 import qualified Development.IDE.GHC.ExactPrint                    as E
 import           Development.IDE.GHC.Util                          (printOutputable,
+                                                                    printOutputableQualified,
                                                                     printRdrName)
 import           Development.IDE.Plugin.CodeAction.Args
 import           Development.IDE.Plugin.CodeAction.ExactPrint
@@ -1258,29 +1259,54 @@ suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..}
                Just [_, _, _, _, fieldName, _, _] -> Just fieldName
                _                                  -> Nothing
 
+-- | 'PrintUnqualified' that renders each name the way the user would write it in
+-- this module: imported names (qualified or not) get GHC's scope-aware rendering,
+-- so a class only reachable through a qualified import keeps its qualifier (#5085).
+-- Names not imported at all fall back to the bare 'OccName', deferring the import
+-- to the import plugin (#4810).
+scopeAwarePprCtx :: HscEnv -> TcGblEnv -> PrintUnqualified
+scopeAwarePprCtx hscEnv tcg = defaultCtx {queryQualifyName = go}
+  where
+    rdrEnv = tcg_rdr_env tcg
+    defaultCtx = mkPrintUnqualifiedDefault hscEnv rdrEnv
+    inScope = S.fromList
+      [ (mdl, occName nm)
+      | GRE nm _ _ _ <- globalRdrEnvElts rdrEnv
+      , Just mdl <- [nameModule_maybe nm]
+      ]
+#if MIN_VERSION_ghc(9,13,0)
+    -- GHC 9.13 (dev cycle of 9.14) added a user-qualifier hint parameter.
+    go mdl hint occ
+      | S.member (mdl, occ) inScope = queryQualifyName defaultCtx mdl hint occ
+      | otherwise                   = NameUnqual
+#else
+    go mdl occ
+      | S.member (mdl, occ) inScope = queryQualifyName defaultCtx mdl occ
+      | otherwise                   = NameUnqual
+#endif
+
 -- | Suggests a constraint for a declaration for which a constraint is missing.
-suggestConstraint :: ParsedSource -> FileDiagnostic -> [(T.Text, Rewrite)]
-suggestConstraint ps fd
-  | Just missingConstraint <- structuredMissingConstraint
-  =
+suggestConstraint
+  :: Maybe HscEnv -> Maybe TcModuleResult -> ParsedSource -> FileDiagnostic
+  -> [(T.Text, Rewrite)]
+suggestConstraint (Just hscEnv) (Just tmr) ps fd =
+  case printOutputableQualified pprCtx <$> fd ^? fdStructuredMessageL
+        . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
+        . _TcRnSolverReport . _1 . reportContentL . _CouldNotDeducePred of
+    Nothing -> []
+    Just mc ->
 #if MIN_VERSION_ghc(9,9,0)
-    let parsedSource = ps in
+      let parsedSource = ps in
 #else
-    let parsedSource = makeDeltaAst ps in
+      let parsedSource = makeDeltaAst ps in
 #endif
-    -- The error site sits in exactly one of the two, so at most one fires.
-       suggestFunctionConstraint parsedSource diag missingConstraint
-    ++ suggestInstanceConstraint parsedSource diag missingConstraint
-  | otherwise = []
-    where
-      diag = fdLspDiagnostic fd
-
-      -- The missing constraint, taken from GHC's structured solver report.
-      structuredMissingConstraint =
-        fmap printOutputable $
-          fd ^? fdStructuredMessageL
-            . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
-            . _TcRnSolverReport . _1 . reportContentL . _CouldNotDeducePred
+      -- The error site sits in exactly one of the two, so at most one fires.
+      suggestFunctionConstraint parsedSource diag mc
+        ++ suggestInstanceConstraint parsedSource diag mc
+  where
+    pprCtx = scopeAwarePprCtx hscEnv (tmrTypechecked tmr)
+    diag = fdLspDiagnostic fd
+suggestConstraint _ _ _ _ = []
 
 -- | Suggests a constraint for an instance declaration for which a constraint is missing.
 suggestInstanceConstraint :: ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]

plugins/hls-refactor-plugin/test/Main.hs

@@ -3033,6 +3033,44 @@ addInstanceConstraintTests = let
     "Add `Eq c` to the context of the instance declaration"
     (incompleteConstraintSourceCode2 Nothing)
     (incompleteConstraintSourceCode2 $ Just "Eq c")
+  , testSession "qualified imported class keeps its qualifier (#5085)" $ do
+      let contentA = T.unlines
+            [ "module MyFunctor where"
+            , ""
+            , "class Functor f where"
+            , "  myFmap :: (a -> b) -> f a -> f b"
+            ]
+          contentB = T.unlines
+            [ "{-# LANGUAGE UndecidableInstances #-}"
+            , "module MyLib where"
+            , ""
+            , "import qualified MyFunctor"
+            , ""
+            , "data Foo a = Foo a"
+            , ""
+            , "instance Functor Foo where"
+            , "  fmap = MyFunctor.myFmap"
+            ]
+      _docA <- createDoc "MyFunctor.hs" "haskell" contentA
+      docB <- createDoc "MyLib.hs" "haskell" contentB
+      _ <- waitForDiagnostics
+      action <- pickActionWithTitle
+        "Add `MyFunctor.Functor Foo` to the context of the instance declaration"
+        =<< getCodeActions docB (R 8 9 8 25)
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      let expected = T.unlines
+            [ "{-# LANGUAGE UndecidableInstances #-}"
+            , "module MyLib where"
+            , ""
+            , "import qualified MyFunctor"
+            , ""
+            , "data Foo a = Foo a"
+            , ""
+            , "instance MyFunctor.Functor Foo => Functor Foo where"
+            , "  fmap = MyFunctor.myFmap"
+            ]
+      liftIO $ expected @=? contentAfterAction
   ]
 
 addFunctionConstraintTests :: TestTree
@@ -3195,6 +3233,42 @@ addFunctionConstraintTests = let
     "Add `Monad m` to the context of the type signature for `f`"
     (quantifiedConstraintSourceCode "((forall a. Eq (f a)), Applicative m)")
     (quantifiedConstraintSourceCode "((forall a. Eq (f a)), Applicative m, Monad m)")
+  , checkCodeAction
+    "missing constraint on a qualified-imported class keeps its qualifier"
+    "Add `Data.String.IsString a` to the context of the type signature for `foo`"
+    (T.unlines
+      [ "module Testing where"
+      , ""
+      , "import qualified Data.String"
+      , ""
+      , "foo :: a"
+      , "foo = Data.String.fromString \"x\""
+      ])
+    (T.unlines
+      [ "module Testing where"
+      , ""
+      , "import qualified Data.String"
+      , ""
+      , "foo :: Data.String.IsString a => a"
+      , "foo = Data.String.fromString \"x\""
+      ])
+  , checkCodeAction
+    "missing constraint on a not-imported class is rendered unqualified"
+    "Add `IsString a` to the context of the type signature for `foo`"
+    (T.unlines
+      [ "{-# LANGUAGE OverloadedStrings #-}"
+      , "module Testing where"
+      , ""
+      , "foo :: a"
+      , "foo = \"x\""
+      ])
+    (T.unlines
+      [ "{-# LANGUAGE OverloadedStrings #-}"
+      , "module Testing where"
+      , ""
+      , "foo :: IsString a => a"
+      , "foo = \"x\""
+      ])
   ]
 
 checkCodeAction :: TestName -> T.Text -> T.Text -> T.Text -> TestTree