From 316d78a4715ba85f75dc714bcb5f3ea0c03b15b7 Mon Sep 17 00:00:00 2001
From: Ganesh Sittampalam <ganesh@earth.li>
Date: Fri, 13 Sep 2019 13:20:10 +0100
Subject: [PATCH] Make sure warnings use unqualified names where appropriate

Because we are constructing the message objects ourselves, as
opposed to error messages which are constructed by GHC, we need
to take care to respect the passed-in 'PprStyle'.
---
 src/Development/IDE/GHC/Warnings.hs |  5 +++--
 test/exe/Main.hs                    | 18 ++++++++++++++++++
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs
index 7b85debb..5a162164 100644
--- a/src/Development/IDE/GHC/Warnings.hs
+++ b/src/Development/IDE/GHC/Warnings.hs
@@ -29,8 +29,9 @@ withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m
 withWarnings diagSource action = do
   warnings <- liftIO $ newVar []
   oldFlags <- getDynFlags
-  let newAction dynFlags _ _ loc _ msg = do
-        let d = diagFromErrMsg diagSource dynFlags $ mkPlainWarnMsg dynFlags loc msg
+  let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
+      newAction dynFlags _ _ loc style msg = do
+        let d = diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg
         modifyVar_ warnings $ return . (d:)
   setLogAction newAction
   res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}
diff --git a/test/exe/Main.hs b/test/exe/Main.hs
index 2376dad3..244c44c5 100644
--- a/test/exe/Main.hs
+++ b/test/exe/Main.hs
@@ -206,6 +206,24 @@ diagnosticTests = testGroup "diagnostics"
             ]
           )
         ]
+  , testSession "unqualified warnings" $ do
+      let fooContent = T.unlines
+            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
+            , "module Foo where"
+            , "foo :: Ord a => a -> Int"
+            , "foo a = 1"
+            ]
+      _ <- openDoc' "Foo.hs" "haskell" fooContent
+      expectDiagnostics
+        [ ( "Foo.hs"
+      -- The test is to make sure that warnings contain unqualified names
+      -- where appropriate. The warning should use an unqualified name 'Ord', not
+      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
+      -- test this is fairly arbitrary.
+          , [(DsWarning, (2, 0), "Redundant constraint: Ord a")
+            ]
+          )
+        ]
   ]
 
 codeActionTests :: TestTree