Commit f09f2470 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

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
parent 12dbc892
......@@ -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,
......
......@@ -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)
......
......@@ -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.
......
......@@ -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
......
{-# 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
(>>) = (*>)
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 ‘(>>) = (*>)’
......@@ -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([
......
......@@ -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 "++
......
Markdown is supported
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