Implement new `-fwarn-noncanonical-monad-instances`

Warn about incoherent/non-canonical 'Applicative'/'Monad' instance
declarations. Specifically the following invariants are checked:

In 'Monad' instances declarations warn if the any of the following
conditions does not hold:

 * 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. `(*>) = (>>)`).

NB, this warning flag is not enabled via `-Wall` nor `-Wcompat`.

This addresses #11128

Reviewers: quchen, austin, bgamari

Reviewed By: bgamari

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

8 files changed, 199 insertions, 1 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9aba2e6ee3..ad05ed5a4d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -528,6 +528,7 @@ data WarningFlag =
    | Opt_WarnUntickedPromotedConstructors
    | Opt_WarnDerivingTypeable
    | Opt_WarnDeferredTypeErrors
+   | Opt_WarnNonCanonicalMonadInstances
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -2904,6 +2905,8 @@ fWarningFlags = [
   flagSpec "warn-missing-exported-sigs"       Opt_WarnMissingExportedSigs,
   flagSpec "warn-monomorphism-restriction"    Opt_WarnMonomorphism,
   flagSpec "warn-name-shadowing"              Opt_WarnNameShadowing,
+  flagSpec "warn-noncanonical-monad-instances"
+                                         Opt_WarnNonCanonicalMonadInstances,
   flagSpec "warn-orphans"                     Opt_WarnOrphans,
   flagSpec "warn-overflowed-literals"         Opt_WarnOverflowedLiterals,
   flagSpec "warn-overlapping-patterns"        Opt_WarnOverlappingPatterns,
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 61c07ca11d..1b234bd088 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -30,7 +30,9 @@ import ForeignCall      ( CCallTarget(..) )
 import Module
 import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
-import PrelNames        ( isUnboundName )
+import PrelNames        ( applicativeClassName, pureAName, thenAName
+                        , monadClassName, returnMName, thenMName
+                        , isUnboundName )
 import Name
 import NameSet
 import NameEnv
@@ -449,6 +451,90 @@ 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:
+--
+-- 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 :: Name -> LHsType 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 "(*>)" "(>>)"
+
+              _ -> 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
+                  -> addWarnNonCanMeth2 "return" "pure"
+
+                  | name == thenMName, isAliasMG mg /= Just thenAName
+                  -> addWarnNonCanMeth2 "(>>)" "(*>)"
+
+              _ -> return ()
+
+  | otherwise = return ()
+  where
+    -- | 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
+    isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
+        | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
+        , L _ EmptyLocalBinds <- lbinds
+        , L _ (HsVar (L _ rhsName)) <- body  = Just rhsName
+    isAliasMG _ = Nothing
+
+    -- got "lhs = rhs" but expected something different
+    addWarnNonCanMeth1 lhs rhs = do
+        addWarn $ 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)
+                       ]
+
+    -- expected "lhs = rhs" but got something else
+    addWarnNonCanMeth2 lhs rhs = do
+        addWarn $ vcat [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Either remove definition for" <+>
+                         quotes (text lhs) <+> text "or define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
+    -- stolen from TcInstDcls
+    instDeclCtxt1 :: LHsType Name -> SDoc
+    instDeclCtxt1 hs_inst_ty
+      = inst_decl_ctxt (case unLoc hs_inst_ty of
+                        HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
+                        _                            -> ppr hs_inst_ty)
+
+    inst_decl_ctxt :: SDoc -> SDoc
+    inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for"))
+                         2 (quotes doc <> text ".")
+
+
 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                            , cid_sigs = uprags, cid_tyfam_insts = ats
@@ -473,6 +559,9 @@ 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'
+
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index 67e2b0f28a..511111f1a0 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -145,6 +145,10 @@ Compiler
    is intended to alert users to cases where they apply ``INLINEABLE`` but
    may not get the speed-up they expect.
 
+-  Added the option ``-fwarn-noncanonical-monad-instances`` which helps
+   detect noncanonical ``Applicative``/``Monad`` 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
    the error might be caused by too restrictive imports.
 
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index db57b187aa..5118168a8c 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -192,6 +192,28 @@ command line.
     Caused a warning to be emitted when a definition was in conflict with
     the AMP (Applicative-Monad proosal).
 
+``-fwarn-noncanonical-monad-instances``
+    .. index::
+       single: -fwarn-noncanonical-monad-instances
+
+    Warn if noncanonical ``Applicative`` or ``Monad`` 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 ``return`` is defined it must be canonical (i.e. ``return = pure``).
+     * If ``(>>)`` is defined it must be canonical (i.e. ``(>>) = (*>)``).
+
+    Moreover, in 'Applicative' instance declarations:
+
+     * Warn if ``pure`` is defined backwards (i.e. ``pure = return``).
+     * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``).
+
+    This option is off by default.
+
 ``-fwarn-missing-monadfail-instance``
     .. index::
        single: -fwarn-missing-monadfail-instance
diff --git a/testsuite/tests/warnings/should_compile/T11128.hs b/testsuite/tests/warnings/should_compile/T11128.hs
new file mode 100644
index 0000000000..081e0748ea
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T11128.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances  #-}
+
+-- | Test noncanonical-monad-instances warnings
+module T11128 where
+
+import Control.Applicative as A
+import Control.Monad as M
+
+----------------------------------------------------------------------------
+-- minimal definition
+
+data T0 a  = T0 a deriving Functor
+
+instance A.Applicative T0 where
+    pure   = T0
+    (<*>)  = M.ap
+
+instance M.Monad T0 where
+    (>>=)  = undefined
+
+----------------------------------------------------------------------------
+-- trigger all 4 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
+
+----------------------------------------------------------------------------
+-- 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
+    (>>)   = (*>)
diff --git a/testsuite/tests/warnings/should_compile/T11128.stderr b/testsuite/tests/warnings/should_compile/T11128.stderr
new file mode 100644
index 0000000000..f924a19306
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T11128.stderr
@@ -0,0 +1,20 @@
+
+T11128.hs:28:5: warning:
+    Noncanonical ‘pure = return’ definition detected
+    in the instance declaration for ‘Applicative T1’.
+    Move definition from ‘return’ to ‘pure’
+
+T11128.hs:30:5: warning:
+    Noncanonical ‘(*>) = (>>)’ definition detected
+    in the instance declaration for ‘Applicative T1’.
+    Move definition from ‘(>>)’ to ‘(*>)’
+
+T11128.hs:34:5: warning:
+    Noncanonical ‘return’ definition detected
+    in the instance declaration for ‘Monad T1’.
+    Either remove definition for ‘return’ or define as ‘return = pure’
+
+T11128.hs:35:5: warning:
+    Noncanonical ‘(>>)’ definition detected
+    in the instance declaration for ‘Monad T1’.
+    Either remove definition for ‘(>>)’ or define as ‘(>>) = (*>)’
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index bbf5d1cc85..3954ba82e0 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -4,6 +4,7 @@ test('T9178', extra_clean(['T9178.o', 'T9178DataType.o',
 			   'T9178.hi', 'T9178DataType.hi']),
 	      multimod_compile, ['T9178', '-Wall'])
 test('T9230', normal, compile_without_flag('-fno-warn-tabs'), [''])
+test('T11128', normal, compile, [''])
 
 test('DeprU',
 	extra_clean([
diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs
index d3c2a5c2c2..e6c6333108 100644
--- a/utils/mkUserGuidePart/Options/Warnings.hs
+++ b/utils/mkUserGuidePart/Options/Warnings.hs
@@ -174,6 +174,15 @@ warningsOptions =
          , flagType = DynamicFlag
          , flagReverse = "-fno-warn-name-shadowing"
          }
+  , flag { flagName = "-fwarn-noncanonical-monad-instance"
+         , flagDescription =
+           "warn when ``Applicative`` or ``Monad`` instances have "++
+           "noncanonical definitions of ``return``, ``pure``, ``(>>)``, "++
+           "or ``(*>)``. "++
+           "See flag description in :ref:`options-sanity` for more details."
+         , flagType = DynamicFlag
+         , flagReverse = "-fno-warn-noncanonical-monad-instance"
+         }
   , flag { flagName = "-fwarn-orphans"
          , flagDescription =
            "warn when the module contains :ref:`orphan instance declarations "++