[Git][ghc/ghc][wip/T24359] improve warning text for T10251

[sheaf (@sheaf)]

sheaf pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC


Commits:
4a2d1f46 by sheaf at 2024-12-04T11:25:51+01:00
improve warning text for T10251

- - - - -


5 changed files:

- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- + testsuite/tests/deSugar/should_compile/T10251.stderr
- testsuite/tests/simplCore/should_compile/T12603.stdout


Changes:

=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -65,6 +65,7 @@ import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
 import GHC.Tc.Types.Evidence
 
 import GHC.Types.Id
+import GHC.Types.Id.Info (IdDetails(..))
 import GHC.Types.Name
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
@@ -992,7 +993,7 @@ finishSpecPrag :: Name -> CoreExpr                    -- RHS to specialise
 finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
                                 spec_bndrs mk_spec_body spec_inl
   | Just reason <- mb_useless
-  = do { diagnosticDs $ DsUselessSpecialisePragma poly_nm reason
+  = do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason
        ; if uselessSpecialisePragmaKeepAnyway reason
          then Just <$> finish_prag
          else return Nothing }
@@ -1084,6 +1085,10 @@ finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
     is_nop_arg (Var x)       = x `elem` spec_bndrs
     is_nop_arg _             = False
 
+    is_dfun = case idDetails poly_id of
+      DFunId {} -> True
+      _ -> False
+
 specFunInlinePrag :: Id -> InlinePragma
                   -> InlinePragma -> InlinePragma
 -- See Note [Activation pragmas for SPECIALISE]


=====================================
compiler/GHC/HsToCore/Errors/Ppr.hs
=====================================
@@ -83,22 +83,27 @@ instance Diagnostic DsMessage where
                StrictBinds       -> "strict bindings"
          in mkSimpleDecorated $
               hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)
-    DsUselessSpecialisePragma poly_id rea ->
+    DsUselessSpecialisePragma poly_nm is_dfun rea ->
       mkSimpleDecorated $
-        what <+> text "SPECIALISE pragma for" <> why
+        what <+> pragma <+> text "pragma" <+> why
       where
-        quoted_id = quotes (ppr poly_id)
+        quoted_nm = quotes (ppr poly_nm)
         what =
           if uselessSpecialisePragmaKeepAnyway rea
           then text "Seemingly useless"
           else text "Ignoring useless"
+        pragma = if is_dfun
+                 then text "SPECIALISE instance"
+                 else text "SPECIALISE"
         why = case rea of
           UselessSpecialiseForClassMethodSelector ->
-            text " class selector:" <+> quoted_id
+            text "for class selector:" <+> quoted_nm
           UselessSpecialiseForNoInlineFunction ->
-            text " NOINLINE function:" <+> quoted_id
+            text "for NOINLINE function:" <+> quoted_nm
           UselessSpecialiseNoSpecialisation ->
-            colon <+> quoted_id
+            if is_dfun
+            then empty
+            else colon <+> quoted_nm
     DsOrphanRule rule
       -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule
     DsRuleLhsTooComplicated orig_lhs lhs2


=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -116,6 +116,7 @@ data DsMessage
     -}
   | DsUselessSpecialisePragma
       !Name
+      !Bool -- ^ is this a @SPECIALISE instance@ pragma?
       !UselessSpecialisePragmaReason
 
   | DsOrphanRule !CoreRule


=====================================
testsuite/tests/deSugar/should_compile/T10251.stderr
=====================================
@@ -0,0 +1,3 @@
+T10251.hs:19:5: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+    Seemingly useless SPECIALISE instance pragma
+


=====================================
testsuite/tests/simplCore/should_compile/T12603.stdout
=====================================
@@ -1 +1 @@
-  = case GHC.Internal.Real.$w$spowImpl1 2# 8# of v { __DEFAULT ->
+  = case GHC.Internal.Real.$w$spowImpl 2# 8# of v { __DEFAULT ->



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a2d1f46040ee2f8e03e2b49acb809f39ff891ee

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a2d1f46040ee2f8e03e2b49acb809f39ff891ee
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241204/635c934d/attachment-0001.html>