Commit 986ceb16 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

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
parent df679403
......@@ -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 ()
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......@@ -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
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 = (<>)’
......@@ -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
......@@ -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 "++
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment