Implement new `-fwarn-noncanonical-monoid-instances`

This is similiar to the `-fwarn-noncanonical-monad-instances` warning
implemented via #11128, but applies to `Semigroup`/`Monoid` instead
and the `(<>)`/`mappend` methods (of which `mappend` is planned to move
out of `Monoid` at some point in the future being redundant and thus
error-prone).

This warning is contained in `-Wcompat` but not in `-Wall`.

This addresses #11150

Reviewed By: quchen

Differential Revision: https://phabricator.haskell.org/D1553

9 files changed, 205 insertions, 47 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 77797320a9..3d99a1a5c0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -525,7 +525,8 @@ data WarningFlag =
    | Opt_WarnUntickedPromotedConstructors
    | Opt_WarnDerivingTypeable
    | Opt_WarnDeferredTypeErrors
-   | Opt_WarnNonCanonicalMonadInstances
+   | Opt_WarnNonCanonicalMonadInstances   -- since 8.0
+   | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -2886,6 +2887,8 @@ fWarningFlags = [
   flagSpec "warn-name-shadowing"              Opt_WarnNameShadowing,
   flagSpec "warn-noncanonical-monad-instances"
                                          Opt_WarnNonCanonicalMonadInstances,
+  flagSpec "warn-noncanonical-monoid-instances"
+                                         Opt_WarnNonCanonicalMonoidInstances,
   flagSpec "warn-orphans"                     Opt_WarnOrphans,
   flagSpec "warn-overflowed-literals"         Opt_WarnOverflowedLiterals,
   flagSpec "warn-overlapping-patterns"        Opt_WarnOverlappingPatterns,
@@ -3462,6 +3465,7 @@ minusWcompatOpts :: [WarningFlag]
 minusWcompatOpts
     = [ Opt_WarnMissingMonadFailInstance
       , Opt_WarnSemigroup
+      , Opt_WarnNonCanonicalMonoidInstances
       ]
 
 enableUnusedBinds :: DynP ()
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 2fbbea4179..6d32ddc268 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -31,7 +31,10 @@ import Module
 import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
-                        , monadClassName, returnMName, thenMName )
+                        , monadClassName, returnMName, thenMName
+                        , semigroupClassName, sappendName
+                        , monoidClassName, mappendName
+                        )
 import Name
 import NameSet
 import NameEnv
@@ -455,47 +458,101 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
   = do { (cid', fvs) <- rnClsInstDecl cid
        ; return (ClsInstD { cid_inst = cid' }, fvs) }
 
--- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
--- declarations. Specifically, the following conditions are verified:
+-- | Warn about non-canonical typeclass instance declarations
 --
--- In 'Monad' instances declarations:
+-- A "non-canonical" instance definition can occur for instances of a
+-- class which redundantly defines an operation its superclass
+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical
+-- instance is one where the subclass inherits its method
+-- implementation from its superclass instance (usually the subclass
+-- has a default method implementation to that effect). Consequently,
+-- a non-canonical instance occurs when this is not the case.
 --
---  * If 'return' is overridden it must be canonical (i.e. @return = pure@).
---  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@).
---
--- In 'Applicative' instance declarations:
---
---  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
---  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
---
-checkCanonicalMonadInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
-checkCanonicalMonadInstances cls poly_ty mbinds
-  | cls == applicativeClassName  = do
-      forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
-          case mbind of
-              FunBind { fun_id = L _ name, fun_matches = mg }
-                  | name == pureAName, isAliasMG mg == Just returnMName
-                  -> addWarnNonCanMeth1 "pure" "return"
-
-                  | name == thenAName, isAliasMG mg == Just thenMName
-                  -> addWarnNonCanMeth1 "(*>)" "(>>)"
+-- See also descriptions of 'checkCanonicalMonadInstances' and
+-- 'checkCanonicalMonoidInstances'
+checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
+checkCanonicalInstances cls poly_ty mbinds = do
+    whenWOptM Opt_WarnNonCanonicalMonadInstances
+        checkCanonicalMonadInstances
 
-              _ -> return ()
+    whenWOptM Opt_WarnNonCanonicalMonoidInstances
+        checkCanonicalMonoidInstances
 
-  | cls == monadClassName  = do
-      forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
-          case mbind of
-              FunBind { fun_id = L _ name, fun_matches = mg }
-                  | name == returnMName, isAliasMG mg /= Just pureAName
-                  -> addWarnNonCanMeth2 "return" "pure"
-
-                  | name == thenMName, isAliasMG mg /= Just thenAName
-                  -> addWarnNonCanMeth2 "(>>)" "(*>)"
-
-              _ -> return ()
-
-  | otherwise = return ()
   where
+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
+    -- declarations. Specifically, the following conditions are verified:
+    --
+    -- In 'Monad' instances declarations:
+    --
+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
+    --
+    -- In 'Applicative' instance declarations:
+    --
+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
+    --
+    checkCanonicalMonadInstances
+      | cls == applicativeClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == pureAName, isAliasMG mg == Just returnMName
+                      -> addWarnNonCanonicalMethod1 "pure" "return"
+
+                      | name == thenAName, isAliasMG mg == Just thenMName
+                      -> addWarnNonCanonicalMethod1 "(*>)" "(>>)"
+
+                  _ -> return ()
+
+      | cls == monadClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == returnMName, isAliasMG mg /= Just pureAName
+                      -> addWarnNonCanonicalMethod2 "return" "pure"
+
+                      | name == thenMName, isAliasMG mg /= Just thenAName
+                      -> addWarnNonCanonicalMethod2 "(>>)" "(*>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | Check whether Monoid(mappend) is defined in terms of
+    -- Semigroup((<>)) (and not the other way round). Specifically,
+    -- the following conditions are verified:
+    --
+    -- In 'Monoid' instances declarations:
+    --
+    --  * If 'mappend' is overridden it must be canonical
+    --    (i.e. @mappend = (<>)@)
+    --
+    -- In 'Semigroup' instance declarations:
+    --
+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
+    --
+    checkCanonicalMonoidInstances
+      | cls == semigroupClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == sappendName, isAliasMG mg == Just mappendName
+                      -> addWarnNonCanonicalMethod1 "(<>)" "mappend"
+
+                  _ -> return ()
+
+      | cls == monoidClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == mappendName, isAliasMG mg /= Just sappendName
+                      -> addWarnNonCanonicalMethod2NoDefault "mappend" "(<>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
     -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
     -- binding, and return @Just rhsName@ if this is the case
     isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name
@@ -506,7 +563,7 @@ checkCanonicalMonadInstances cls poly_ty mbinds
     isAliasMG _ = Nothing
 
     -- got "lhs = rhs" but expected something different
-    addWarnNonCanMeth1 lhs rhs = do
+    addWarnNonCanonicalMethod1 lhs rhs = do
         addWarn $ vcat [ text "Noncanonical" <+>
                          quotes (text (lhs ++ " = " ++ rhs)) <+>
                          text "definition detected"
@@ -517,7 +574,7 @@ checkCanonicalMonadInstances cls poly_ty mbinds
                        ]
 
     -- expected "lhs = rhs" but got something else
-    addWarnNonCanMeth2 lhs rhs = do
+    addWarnNonCanonicalMethod2 lhs rhs = do
         addWarn $ vcat [ text "Noncanonical" <+>
                          quotes (text lhs) <+>
                          text "definition detected"
@@ -527,6 +584,16 @@ checkCanonicalMonadInstances cls poly_ty mbinds
                          quotes (text (lhs ++ " = " ++ rhs))
                        ]
 
+    -- like above, but method has no default impl
+    addWarnNonCanonicalMethod2NoDefault lhs rhs = do
+        addWarn $ vcat [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
     -- stolen from TcInstDcls
     instDeclCtxt1 :: LHsSigType Name -> SDoc
     instDeclCtxt1 hs_inst_ty
@@ -558,8 +625,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
           -- forall-d tyvars scope over the method bindings too
        ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
 
-       ; whenWOptM Opt_WarnNonCanonicalMonadInstances $
-         checkCanonicalMonadInstances cls inst_ty' mbinds'
+       ; checkCanonicalInstances cls inst_ty' mbinds'
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index deb0e5459d..b79ae8a674 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -54,8 +54,8 @@ standard “packages” of warnings:
     eager to make their code future compatible to adapt to new features before
     they even generate warnings.
 
-    This currently enables ``-fwarn-missing-monadfail-instance`` and
-    ``-fwarn-semigroup``.
+    This currently enables ``-fwarn-missing-monadfail-instance``,
+    ``-fwarn-semigroup``, and ``-fwarn-noncanonical-monoid-instances``.
 
 ``-Wno-compat``
     .. index::
@@ -232,6 +232,28 @@ command line.
 
     This option is off by default.
 
+``-fwarn-noncanonical-monoid-instances``
+    .. index::
+       single: -fwarn-noncanonical-monoid-instances
+
+    Warn if noncanonical ``Semigroup`` or ``Monoid`` instances
+    declarations are detected.
+
+    When this warning is enabled, the following conditions are verified:
+
+    In ``Monoid`` instances declarations warn if any of the following
+    conditions does not hold:
+
+     * If ``mappend`` is defined it must be canonical
+       (i.e. ``mappend = (Data.Semigroup.<>)``).
+
+    Moreover, in 'Semigroup' instance declarations:
+
+     * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``).
+
+    This warning is off by default. However, it is part of the
+    ``-Wcompat`` option group.
+
 ``-fwarn-missing-monadfail-instance``
     .. index::
        single: -fwarn-missing-monadfail-instance
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
index 24cab851c9..64a19e5cf9 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
@@ -6,9 +6,21 @@
 
 module WCompatWarningsNotOn where
 
+import qualified Data.Semigroup as Semi
+
 monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
 
 (<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+  (<>) = mappend
+
+instance Semi.Monoid S where
+  S a `mappend` S b = S (a+b)
+  mempty = S 0
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
index 4c53a1e4ea..6ed25f1ef7 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
@@ -6,9 +6,21 @@
 
 module WCompatWarningsOff where
 
+import qualified Data.Semigroup as Semi
+
 monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
 
 (<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+  (<>) = mappend
+
+instance Semi.Monoid S where
+  S a `mappend` S b = S (a+b)
+  mempty = S 0
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
index 3b2586aff8..c155f37f42 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
@@ -6,9 +6,21 @@
 
 module WCompatWarningsOn where
 
+import qualified Data.Semigroup as Semi
+
 monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
 
 (<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+  (<>) = mappend
+
+instance Semi.Monoid S where
+  S a `mappend` S b = S (a+b)
+  mempty = S 0
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
index 7b6b501708..5de8745544 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
@@ -1,12 +1,12 @@
 
-WCompatWarningsOn.hs:11:5: warning:
+WCompatWarningsOn.hs:13:5: warning:
     • Could not deduce (MonadFail m)
         arising from the failable pattern ‘Just _’
         (this will become an error a future GHC release)
       from the context: Monad m
         bound by the type signature for:
                    monadFail :: Monad m => m a
-        at WCompatWarningsOn.hs:9:1-27
+        at WCompatWarningsOn.hs:11:1-27
       Possible fix:
         add (MonadFail m) to the context of
           the type signature for:
@@ -20,6 +20,16 @@ WCompatWarningsOn.hs:11:5: warning:
             = do { Just _ <- undefined;
                    undefined }
 
-WCompatWarningsOn.hs:14:1: warning:
+WCompatWarningsOn.hs:16:1: warning:
     Local definition of ‘<>’ clashes with a future Prelude name.
     This will become an error in a future release.
+
+WCompatWarningsOn.hs:22:3: warning:
+    Noncanonical ‘(<>) = mappend’ definition detected
+    in the instance declaration for ‘Semigroup S’.
+    Move definition from ‘mappend’ to ‘(<>)’
+
+WCompatWarningsOn.hs:25:3: warning:
+    Noncanonical ‘mappend’ definition detected
+    in the instance declaration for ‘Monoid S’.
+    Define as ‘mappend = (<>)’
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
index 2f4aedff23..44f554ee47 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
@@ -6,9 +6,21 @@
 
 module WCompatWarningsOnOff where
 
+import qualified Data.Semigroup as Semi
+
 monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
 
 (<>) = undefined -- Semigroup warnings
+
+-- -fwarn-noncanonical-monoid-instances
+newtype S = S Int
+
+instance Semi.Semigroup S where
+  (<>) = mappend
+
+instance Semi.Monoid S where
+  S a `mappend` S b = S (a+b)
+  mempty = S 0
diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs
index ba93f6ca83..cef654d6c1 100644
--- a/utils/mkUserGuidePart/Options/Warnings.hs
+++ b/utils/mkUserGuidePart/Options/Warnings.hs
@@ -197,6 +197,14 @@ warningsOptions =
          , flagType = DynamicFlag
          , flagReverse = "-fno-warn-noncanonical-monad-instance"
          }
+  , flag { flagName = "-fwarn-noncanonical-monoid-instance"
+         , flagDescription =
+           "warn when ``Semigroup`` or ``Monoid`` instances have "++
+           "noncanonical definitions of ``(<>)`` or ``mappend``. "++
+           "See flag description in :ref:`options-sanity` for more details."
+         , flagType = DynamicFlag
+         , flagReverse = "-fno-warn-noncanonical-monoid-instance"
+         }
   , flag { flagName = "-fwarn-orphans"
          , flagDescription =
            "warn when the module contains :ref:`orphan instance declarations "++