diff options
author | Herbert Valerio Riedel <hvr@gnu.org> | 2015-11-24 12:46:33 +0100 |
---|---|---|
committer | Herbert Valerio Riedel <hvr@gnu.org> | 2015-11-24 12:47:39 +0100 |
commit | f09f2470a76bb08b7f51d2f5663daa672b86f618 (patch) | |
tree | c1caef650e832d4f868ba6260ca4a452dccbc353 | |
parent | 12dbc89228d9a13c011e4f399db1bdc0fa4681f0 (diff) | |
download | haskell-f09f2470a76bb08b7f51d2f5663daa672b86f618.tar.gz |
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
-rw-r--r-- | compiler/main/DynFlags.hs | 3 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 91 | ||||
-rw-r--r-- | docs/users_guide/7.12.1-notes.rst | 4 | ||||
-rw-r--r-- | docs/users_guide/using-warnings.rst | 22 | ||||
-rw-r--r-- | testsuite/tests/warnings/should_compile/T11128.hs | 50 | ||||
-rw-r--r-- | testsuite/tests/warnings/should_compile/T11128.stderr | 20 | ||||
-rw-r--r-- | testsuite/tests/warnings/should_compile/all.T | 1 | ||||
-rw-r--r-- | utils/mkUserGuidePart/Options/Warnings.hs | 9 |
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 "++ |