Implement `-Wnoncanonical-monadfail-instances` warning

The MonadFail proposal implemented so far via #10751 only warns about
missing `MonadFail` instances based on existence of failible pattern
matches in `do`-blocks.

However, based on the noncanonical Monad warnings implemented via #11150
we can provide a different mechanism for detecting missing `MonadFail`
instances quite cheaply. That is, by checking for canonical `fail` definitions.

In the case of `Monad`/`MonadFail`, we define the canonical implementation of
`fail` to be such that the soft-deprecated method shall (iff overridden) be
defined in terms of the non-deprecated method. Consequently, in case of
`MonadFail`, the `Monad(fail)` method shall be defined as alias of
the `MonadFail(fail)` method.

This allows us at some distant point in the future to remove `fail` from
the `Monad` class, while having GHC ignore/tolerate such literal canonical
method definitions.

Reviewed By: bgamari, RyanGlScott

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

8 files changed, 151 insertions, 2 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c9b7a993e3..5189e235fa 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -594,6 +594,7 @@ data WarningFlag =
    | Opt_WarnDerivingTypeable
    | Opt_WarnDeferredTypeErrors
    | Opt_WarnNonCanonicalMonadInstances   -- since 8.0
+   | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0
    | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0
    | Opt_WarnMissingPatSynSigs            -- since 8.0
    deriving (Eq, Show, Enum)
@@ -2933,6 +2934,8 @@ wWarningFlags = [
   flagSpec "name-shadowing"              Opt_WarnNameShadowing,
   flagSpec "noncanonical-monad-instances"
                                          Opt_WarnNonCanonicalMonadInstances,
+  flagSpec "noncanonical-monadfail-instances"
+                                         Opt_WarnNonCanonicalMonadFailInstances,
   flagSpec "noncanonical-monoid-instances"
                                          Opt_WarnNonCanonicalMonoidInstances,
   flagSpec "orphans"                     Opt_WarnOrphans,
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 3751dfb2d2..ad5418a046 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -32,6 +32,7 @@ import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
                         , monadClassName, returnMName, thenMName
+                        , monadFailClassName, failMName, failMName_preMFP
                         , semigroupClassName, sappendName
                         , monoidClassName, mappendName
                         )
@@ -473,6 +474,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
     whenWOptM Opt_WarnNonCanonicalMonadInstances
         checkCanonicalMonadInstances
 
+    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
+        checkCanonicalMonadFailInstances
+
     whenWOptM Opt_WarnNonCanonicalMonoidInstances
         checkCanonicalMonoidInstances
 
@@ -517,6 +521,40 @@ checkCanonicalInstances cls poly_ty mbinds = do
 
       | otherwise = return ()
 
+    -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
+    -- declarations. Specifically, the following conditions are verified:
+    --
+    -- In 'Monad' instances declarations:
+    --
+    --  * If 'fail' is overridden it must be canonical
+    --    (i.e. @fail = Control.Monad.Fail.fail@)
+    --
+    -- In 'MonadFail' instance declarations:
+    --
+    --  * Warn if 'fail' is defined backwards
+    --    (i.e. @fail = Control.Monad.fail@).
+    --
+    checkCanonicalMonadFailInstances
+      | cls == monadFailClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == failMName, isAliasMG mg == Just failMName_preMFP
+                      -> addWarnNonCanonicalMethod1 "fail" "Control.Monad.fail"
+
+                  _ -> 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 == failMName_preMFP, isAliasMG mg /= Just failMName
+                      -> addWarnNonCanonicalMethod2 "fail"
+                                                    "Control.Monad.Fail.fail"
+                  _ -> 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:
diff --git a/docs/users_guide/8.0.1-notes.rst b/docs/users_guide/8.0.1-notes.rst
index e8a2c0e902..153a4d331b 100644
--- a/docs/users_guide/8.0.1-notes.rst
+++ b/docs/users_guide/8.0.1-notes.rst
@@ -238,8 +238,9 @@ Compiler
    is intended to alert users to cases where they apply ``INLINEABLE`` but
    may not get the speed-up they expect.
 
--  Added the option :ghc-flag:`-Wnoncanonical-monad-instances` which helps
-   detect noncanonical ``Applicative``/``Monad`` instance definitions.
+-  Added the option :ghc-flag:`-Wnoncanonical-monad-instances` and
+   :ghc-flag:`-Wnoncanonical-monadfail-instances` which help detect noncanonical
+   ``Applicative``/``Monad``/``MonadFail`` instance definitions.
    See flag description in :ref:`options-sanity` for more details.
 
 -  When printing an out-of-scope error message, GHC will give helpful advice if
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 07ddbb12d5..fb9c913500 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -224,6 +224,28 @@ of ``-W(no-)*``.
 
     This option is off by default.
 
+.. ghc-flag:: -Wnoncanonical-monadfail-instances
+
+    Warn if noncanonical ``Monad`` or ``MonadFail`` instances
+    declarations are detected.
+
+    When this warning is enabled, the following conditions are verified:
+
+    In ``Monad`` instances declarations warn if any of the following
+    conditions does not hold:
+
+     * If ``fail`` is defined it must be canonical
+       (i.e. ``fail = Control.Monad.Fail.fail``).
+
+    Moreover, in ``MonadFail`` instance declarations:
+
+     * Warn if ``fail`` is defined backwards
+       (i.e. ``fail = Control.Monad.fail``).
+
+    See also :ghc-flag:`-Wmissing-monadfail-instance`.
+
+    This option is off by default.
+
 .. ghc-flag:: -Wnoncanonical-monoid-instances
 
     Warn if noncanonical ``Semigroup`` or ``Monoid`` instances
@@ -253,6 +275,8 @@ of ``-W(no-)*``.
     Warn when a failable pattern is used in a do-block that does not have a
     ``MonadFail`` instance.
 
+    See also :ghc-flag:`-Wnoncanonical-monadfail-instances`.
+
     Being part of the :ghc-flag:`-Wcompat` option group, this warning is off by
     default, but will be switched on in a future GHC release, as part of
     the `MonadFail Proposal (MFP)
diff --git a/testsuite/tests/warnings/should_compile/T11128b.hs b/testsuite/tests/warnings/should_compile/T11128b.hs
new file mode 100644
index 0000000000..2cca9a53e0
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T11128b.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -Wnoncanonical-monadfail-instances  #-}
+
+-- | Test noncanonical-monadfail-instances warnings
+module T11128b where
+
+import Control.Applicative as A
+import Control.Monad as M
+import Control.Monad.Fail as MF
+
+----------------------------------------------------------------------------
+-- minimal definition
+
+data T0 a  = T0 a deriving Functor
+
+instance A.Applicative T0 where
+    pure   = T0
+    (<*>)  = M.ap
+
+instance M.Monad T0 where
+    (>>=)  = undefined
+
+instance MF.MonadFail T0 where
+    fail   = error "fail"
+
+----------------------------------------------------------------------------
+-- trigger all 2 warnings
+
+data T1 a  = T1 a deriving Functor
+
+instance A.Applicative T1 where
+    pure   = return
+    (<*>)  = M.ap
+    (*>)   = (M.>>)
+
+instance M.Monad T1 where
+    (>>=)  = undefined
+    return = T1
+    (>>)   = undefined
+    fail   = error "fail"
+
+instance MF.MonadFail T1 where
+    fail   = M.fail
+
+----------------------------------------------------------------------------
+-- backward compat canonical defintion
+
+data T2 a  = T2 a deriving Functor
+
+instance Applicative T2 where
+    pure   = T2
+    (<*>)  = ap
+    (*>)   = undefined
+
+instance M.Monad T2 where
+    (>>=)  = undefined
+    return = pure
+    (>>)   = (*>)
+    fail   = MF.fail
+
+instance MF.MonadFail T2 where
+    fail   = error "fail"
+
+----------------------------------------------------------------------------
diff --git a/testsuite/tests/warnings/should_compile/T11128b.stderr b/testsuite/tests/warnings/should_compile/T11128b.stderr
new file mode 100644
index 0000000000..57aa22beea
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T11128b.stderr
@@ -0,0 +1,10 @@
+
+T11128b.hs:40:5: warning:
+    Noncanonical ‘fail’ definition detected
+    in the instance declaration for ‘Monad T1’.
+    Either remove definition for ‘fail’ or define as ‘fail = Control.Monad.Fail.fail’
+
+T11128b.hs:43:5: warning:
+    Noncanonical ‘fail = Control.Monad.fail’ definition detected
+    in the instance declaration for ‘MonadFail T1’.
+    Move definition from ‘Control.Monad.fail’ to ‘fail’
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index a2b1860ba4..2e7132213c 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -7,6 +7,7 @@ test('T9230', normal, compile_without_flag('-fno-warn-tabs'), [''])
 test('T10908', normal, compile, [''])
 test('T11077', normal, compile, ['-fwarn-missing-exported-sigs'])
 test('T11128', normal, compile, [''])
+test('T11128b', normal, compile, [''])
 test('PluralS', normal, compile, [''])
 
 test('DeprU',
diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs
index e7c93e1d7c..0c5260f434 100644
--- a/utils/mkUserGuidePart/Options/Warnings.hs
+++ b/utils/mkUserGuidePart/Options/Warnings.hs
@@ -197,6 +197,14 @@ warningsOptions =
          , flagType = DynamicFlag
          , flagReverse = "-Wno-noncanonical-monad-instances"
          }
+  , flag { flagName = "-Wnoncanonical-monadfail-instances"
+         , flagDescription =
+           "warn when ``Monad`` or ``MonadFail`` instances have "++
+           "noncanonical definitions of ``fail``."++
+           "See flag description in :ref:`options-sanity` for more details."
+         , flagType = DynamicFlag
+         , flagReverse = "-Wno-noncanonical-monadfail-instances"
+         }
   , flag { flagName = "-Wnoncanonical-monoid-instances"
          , flagDescription =
            "warn when ``Semigroup`` or ``Monoid`` instances have "++