Add structured error messages for GHC.Rename.Module

Tracking ticket: #20115

MR: !10361

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

Only addresses the single warning missing from the previous MR.

7 files changed, 181 insertions, 62 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index df49034d13..3496b2af5a 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -929,6 +929,7 @@ minusWcompatOpts :: [WarningFlag]
 minusWcompatOpts
     = [ Opt_WarnSemigroup
       , Opt_WarnNonCanonicalMonoidInstances
+      , Opt_WarnNonCanonicalMonadInstances
       , Opt_WarnCompatUnqualifiedImports
       , Opt_WarnTypeEqualityOutOfScope
       ]
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index e91749cf2d..319dececdd 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -22,7 +22,6 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
 import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
 
 import GHC.Hs
-import GHC.Types.Error
 import GHC.Types.FieldLabel
 import GHC.Types.Name.Reader
 import GHC.Rename.HsType
@@ -452,11 +451,9 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
 checkCanonicalInstances cls poly_ty mbinds = do
     whenWOptM Opt_WarnNonCanonicalMonadInstances
         $ checkCanonicalMonadInstances
-        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
 
     whenWOptM Opt_WarnNonCanonicalMonoidInstances
         $ checkCanonicalMonoidInstances
-        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
 
   where
     -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance
@@ -472,19 +469,17 @@ checkCanonicalInstances cls poly_ty mbinds = do
     --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
     --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
     --
-    checkCanonicalMonadInstances refURL
+    checkCanonicalMonadInstances
       | cls == applicativeClassName =
           forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
               case mbind of
                   FunBind { fun_id = L _ name
                           , fun_matches = mg }
                       | name == pureAName, isAliasMG mg == Just returnMName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
+                      -> addWarnNonCanonicalMonad NonCanonical_Pure
 
                       | name == thenAName, isAliasMG mg == Just thenMName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
+                      -> addWarnNonCanonicalMonad NonCanonical_ThenA
 
                   _ -> return ()
 
@@ -494,12 +489,10 @@ checkCanonicalInstances cls poly_ty mbinds = do
                   FunBind { fun_id = L _ name
                           , fun_matches = mg }
                       | name == returnMName, isAliasMG mg /= Just pureAName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
+                      -> addWarnNonCanonicalMonad NonCanonical_Return
 
                       | name == thenMName, isAliasMG mg /= Just thenAName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
+                      -> addWarnNonCanonicalMonad NonCanonical_ThenM
 
                   _ -> return ()
 
@@ -518,15 +511,14 @@ checkCanonicalInstances cls poly_ty mbinds = do
     --
     --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
     --
-    checkCanonicalMonoidInstances refURL
+    checkCanonicalMonoidInstances
       | cls == semigroupClassName =
           forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
               case mbind of
                   FunBind { fun_id      = L _ name
                           , fun_matches = mg }
                       | name == sappendName, isAliasMG mg == Just mappendName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
+                      -> addWarnNonCanonicalMonoid NonCanonical_Sappend
 
                   _ -> return ()
 
@@ -536,9 +528,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
                   FunBind { fun_id = L _ name
                           , fun_matches = mg }
                       | name == mappendName, isAliasMG mg /= Just sappendName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonoidInstances
-                            "mappend" "(<>)"
+                      -> addWarnNonCanonicalMonoid NonCanonical_Mappend
 
                   _ -> return ()
 
@@ -554,51 +544,14 @@ checkCanonicalInstances cls poly_ty mbinds = do
         , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)
     isAliasMG _ = Nothing
 
-    -- got "lhs = rhs" but expected something different
-    addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
-        let dia = mkTcRnUnknownMessage $
-              mkPlainDiagnostic (WarningWithFlag flag) noHints $
-                vcat [ text "Noncanonical" <+>
-                       quotes (text (lhs ++ " = " ++ rhs)) <+>
-                       text "definition detected"
-                     , instDeclCtxt1 poly_ty
-                     , text "Move definition from" <+>
-                       quotes (text rhs) <+>
-                       text "to" <+> quotes (text lhs)
-                     , text "See also:" <+>
-                       text refURL
-                     ]
-        addDiagnostic dia
-
-    -- expected "lhs = rhs" but got something else
-    addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
-        let dia = mkTcRnUnknownMessage $
-              mkPlainDiagnostic (WarningWithFlag flag) noHints $
-                vcat [ text "Noncanonical" <+>
-                       quotes (text lhs) <+>
-                       text "definition detected"
-                     , instDeclCtxt1 poly_ty
-                     , quotes (text lhs) <+>
-                       text "will eventually be removed in favour of" <+>
-                       quotes (text rhs)
-                     , text "Either remove definition for" <+>
-                       quotes (text lhs) <+> text "(recommended)" <+>
-                       text "or define as" <+>
-                       quotes (text (lhs ++ " = " ++ rhs))
-                     , text "See also:" <+>
-                       text refURL
-                     ]
-        addDiagnostic dia
-
-    -- stolen from GHC.Tc.TyCl.Instance
-    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
-    instDeclCtxt1 hs_inst_ty
-      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
-
-    inst_decl_ctxt :: SDoc -> SDoc
-    inst_decl_ctxt doc = hang (text "in the instance declaration for")
-                         2 (quotes doc <> text ".")
+    addWarnNonCanonicalMonoid reason =
+      addWarnNonCanonicalDefinition (NonCanonicalMonoid reason)
 
+    addWarnNonCanonicalMonad reason =
+      addWarnNonCanonicalDefinition (NonCanonicalMonad reason)
+
+    addWarnNonCanonicalDefinition reason =
+      addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty)
 
 rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 751a5f7682..269063ae65 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1859,6 +1859,9 @@ instance Diagnostic TcRnMessage where
            locations =
              text "Bound at:"
              <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs)))
+    TcRnNonCanonicalDefinition reason inst_ty
+      -> mkSimpleDecorated $
+         pprNonCanonicalDefinition inst_ty reason
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -2484,6 +2487,11 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnBindingNameConflict{}
       -> ErrorWithoutFlag
+    TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _
+      -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances
+    TcRnNonCanonicalDefinition (NonCanonicalMonad _) _
+      -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances
+
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -3145,6 +3153,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnBindingNameConflict{}
       -> noHints
+    TcRnNonCanonicalDefinition reason _
+      -> suggestNonCanonicalDefinition reason
 
   diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode
   diagnosticCode = constructorCode
@@ -5451,3 +5461,78 @@ pprAmbiguousGreName gre
         | otherwise
         = pprPanic "addNameClassErrRn" (ppr gre)
           -- Invariant: either 'lcl' is True or 'iss' is non-empty
+
+pprNonCanonicalDefinition :: LHsSigType GhcRn
+                          -> NonCanonicalDefinition
+                          -> SDoc
+pprNonCanonicalDefinition inst_ty = \case
+  NonCanonicalMonoid sub -> case sub of
+    NonCanonical_Sappend ->
+      msg1 "(<>)" "mappend"
+    NonCanonical_Mappend ->
+      msg2 "mappend" "(<>)"
+  NonCanonicalMonad sub -> case sub of
+    NonCanonical_Pure ->
+      msg1 "pure" "return"
+    NonCanonical_ThenA ->
+      msg1 "(*>)" "(>>)"
+    NonCanonical_Return ->
+      msg2 "return" "pure"
+    NonCanonical_ThenM ->
+      msg2 "(>>)" "(*>)"
+  where
+    msg1 :: String -> String -> SDoc
+    msg1 lhs rhs =
+      vcat [ text "Noncanonical" <+>
+            quotes (text (lhs ++ " = " ++ rhs)) <+>
+            text "definition detected"
+          , inst
+          ]
+
+    msg2 :: String -> String -> SDoc
+    msg2 lhs rhs =
+      vcat [ text "Noncanonical" <+>
+            quotes (text lhs) <+>
+            text "definition detected"
+          , inst
+          , quotes (text lhs) <+>
+            text "will eventually be removed in favour of" <+>
+            quotes (text rhs)
+          ]
+
+    inst = instDeclCtxt1 inst_ty
+
+    -- stolen from GHC.Tc.TyCl.Instance
+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+    instDeclCtxt1 hs_inst_ty
+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+    inst_decl_ctxt :: SDoc -> SDoc
+    inst_decl_ctxt doc = hang (text "in the instance declaration for")
+                         2 (quotes doc <> text ".")
+
+suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint]
+suggestNonCanonicalDefinition reason =
+  [action doc]
+  where
+    action = case reason of
+      NonCanonicalMonoid sub -> case sub of
+        NonCanonical_Sappend -> move sappendName mappendName
+        NonCanonical_Mappend -> remove mappendName sappendName
+      NonCanonicalMonad sub -> case sub of
+        NonCanonical_Pure -> move pureAName returnMName
+        NonCanonical_ThenA -> move thenAName thenMName
+        NonCanonical_Return -> remove returnMName pureAName
+        NonCanonical_ThenM -> remove thenMName thenAName
+
+    move = SuggestMoveNonCanonicalDefinition
+    remove = SuggestRemoveNonCanonicalDefinition
+
+    doc = case reason of
+      NonCanonicalMonoid _ -> doc_monoid
+      NonCanonicalMonad _ -> doc_monad
+
+    doc_monoid =
+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
+    doc_monad =
+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 23dc2cd3b0..68c5ca2869 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -116,6 +116,9 @@ module GHC.Tc.Errors.Types (
   , UnusedImportName (..)
   , NestedForallsContextsIn(..)
   , UnusedNameProv(..)
+  , NonCanonicalDefinition(..)
+  , NonCanonical_Monoid(..)
+  , NonCanonical_Monad(..)
   ) where
 
 import GHC.Prelude
@@ -4037,6 +4040,19 @@ data TcRnMessage where
                              -- ^ The locations of the duplicates
                           -> TcRnMessage
 
+  {-| TcRnNonCanonicalDefinition is a warning indicating that an instance
+    defines an implementation for a method that should not be defined in a way
+    that deviates from its default implementation, for example because it has
+    been scheduled to be absorbed into another method, like @pure@ making
+    @return@ obsolete.
+
+    Test cases:
+      WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff
+  -}
+  TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics
+                             -> !(LHsSigType GhcRn) -- ^ The instance type
+                             -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -5567,3 +5583,34 @@ data UnusedNameProv
   | UnusedNameTypePattern
   | UnusedNameMatch
   | UnusedNameLocalBind
+
+-- | Different reasons for TcRnNonCanonicalDefinition.
+data NonCanonicalDefinition =
+  -- | Related to @(<>)@ and @mappend@.
+  NonCanonicalMonoid NonCanonical_Monoid
+  |
+  -- | Related to @(*>)@/@(>>)@ and @pure@/@return@.
+  NonCanonicalMonad NonCanonical_Monad
+  deriving (Generic)
+
+-- | Possible cases for the -Wnoncanonical-monoid-instances.
+data NonCanonical_Monoid =
+  -- | @(<>) = mappend@ was defined.
+  NonCanonical_Sappend
+  |
+  -- | @mappend@ was defined as something other than @(<>)@.
+  NonCanonical_Mappend
+
+-- | Possible cases for the -Wnoncanonical-monad-instances.
+data NonCanonical_Monad =
+  -- | @pure = return@ was defined.
+  NonCanonical_Pure
+  |
+  -- | @(*>) = (>>)@ was defined.
+  NonCanonical_ThenA
+  |
+  -- | @return@ was defined as something other than @pure@.
+  NonCanonical_Return
+  |
+  -- | @(>>)@ was defined as something other than @(*>)@.
+  NonCanonical_ThenM
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index cb80f713d4..33cdd696f3 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -598,6 +598,8 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnIllegalInferredTyVars"                     = 54832
   GhcDiagnosticCode "TcRnAmbiguousName"                             = 87543
   GhcDiagnosticCode "TcRnBindingNameConflict"                       = 10498
+  GhcDiagnosticCode "NonCanonicalMonoid"                            = 50928
+  GhcDiagnosticCode "NonCanonicalMonad"                             = 22705
 
   -- PatSynInvalidRhsReason
   GhcDiagnosticCode "PatSynNotInvertible"                           = 69317
@@ -856,6 +858,7 @@ type family ConRecursInto con where
   ConRecursInto "DodgyImportsHiding"       = 'Just ImportLookupReason
   ConRecursInto "TcRnImportLookup"         = 'Just ImportLookupReason
   ConRecursInto "TcRnUnusedImport"         = 'Just UnusedImportReason
+  ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition
 
     --
     -- TH errors
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 773ed4941d..7057925dea 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -438,6 +438,21 @@ data GhcHint
         bind anything useful.
     -}
   | SuggestRemoveRecordWildcard
+    {-| Suggest moving a method implementation to a different instance to its
+      superclass that defines the canonical version of the method.
+    -}
+  | SuggestMoveNonCanonicalDefinition
+    Name -- ^ move the implementation from this method
+    Name -- ^ ... to this method
+    String -- ^ Documentation URL
+
+    {-| Suggest removing a method implementation when a superclass defines the
+      canonical version of that method.
+    -}
+  | SuggestRemoveNonCanonicalDefinition
+    Name -- ^ method with non-canonical implementation
+    Name -- ^ possible other method to use as the RHS instead
+    String -- ^ Documentation URL
 
 -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
 -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 76e678bb36..4454d872cd 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -234,6 +234,17 @@ instance Outputable GhcHint where
       -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe."
     SuggestRemoveRecordWildcard
       -> text "Omit the" <+> quotes (text "..")
+    SuggestMoveNonCanonicalDefinition lhs rhs refURL ->
+      text "Move definition from" <+>
+      quotes (pprPrefixUnqual rhs) <+>
+      text "to" <+> quotes (pprPrefixUnqual lhs) $$
+      text "See also:" <+> text refURL
+    SuggestRemoveNonCanonicalDefinition lhs rhs refURL ->
+      text "Either remove definition for" <+>
+      quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+>
+      text "or define as" <+>
+      quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$
+      text "See also:" <+> text refURL
 
 perhapsAsPat :: SDoc
 perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
@@ -343,3 +354,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
     pp_ns rdr | ns /= tried_ns = pprNameSpace ns
               | otherwise      = empty
       where ns = rdrNameSpace rdr
+
+pprPrefixUnqual :: Name -> SDoc
+pprPrefixUnqual name =
+  pprPrefixOcc (getOccName name)