Commit e60ae8a3 authored by Fumiaki Kinoshita's avatar Fumiaki Kinoshita 💬 Committed by Marge Bot

Add -Wnoncanonical-{monad,monoid}-instances to standardWarnings

```----------------------
Metric Decrease:
   T12425
Metric Increase:
   T17516
```

----------------------
parent bf2411a3
Pipeline #26311 passed with stages
in 346 minutes and 6 seconds
......@@ -4082,7 +4082,9 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnSimplifiableClassConstraints,
Opt_WarnStarBinder,
Opt_WarnInaccessibleCode,
Opt_WarnSpaceAfterBang
Opt_WarnSpaceAfterBang,
Opt_WarnNonCanonicalMonadInstances,
Opt_WarnNonCanonicalMonoidInstances
]
-- | Things you get with -W
......
......@@ -426,10 +426,12 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances cls poly_ty mbinds = do
whenWOptM Opt_WarnNonCanonicalMonadInstances
checkCanonicalMonadInstances
$ checkCanonicalMonadInstances
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
whenWOptM Opt_WarnNonCanonicalMonoidInstances
checkCanonicalMonoidInstances
$ checkCanonicalMonoidInstances
"https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
where
-- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
......@@ -445,18 +447,18 @@ checkCanonicalInstances cls poly_ty mbinds = do
-- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
-- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
--
checkCanonicalMonadInstances
checkCanonicalMonadInstances refURL
| 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
-> addWarnNonCanonicalMethod1 refURL
Opt_WarnNonCanonicalMonadInstances "pure" "return"
| name == thenAName, isAliasMG mg == Just thenMName
-> addWarnNonCanonicalMethod1
-> addWarnNonCanonicalMethod1 refURL
Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
_ -> return ()
......@@ -467,11 +469,11 @@ checkCanonicalInstances cls poly_ty mbinds = do
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == returnMName, isAliasMG mg /= Just pureAName
-> addWarnNonCanonicalMethod2
-> addWarnNonCanonicalMethod2 refURL
Opt_WarnNonCanonicalMonadInstances "return" "pure"
| name == thenMName, isAliasMG mg /= Just thenAName
-> addWarnNonCanonicalMethod2
-> addWarnNonCanonicalMethod2 refURL
Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
_ -> return ()
......@@ -491,14 +493,14 @@ checkCanonicalInstances cls poly_ty mbinds = do
--
-- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
--
checkCanonicalMonoidInstances
checkCanonicalMonoidInstances refURL
| 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
-> addWarnNonCanonicalMethod1 refURL
Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
_ -> return ()
......@@ -509,8 +511,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == mappendName, isAliasMG mg /= Just sappendName
-> addWarnNonCanonicalMethod2NoDefault
Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
-> addWarnNonCanonicalMethod2 refURL
Opt_WarnNonCanonicalMonoidInstances
"mappend" "(<>)"
_ -> return ()
......@@ -527,7 +530,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
isAliasMG _ = Nothing
-- got "lhs = rhs" but expected something different
addWarnNonCanonicalMethod1 flag lhs rhs = do
addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
addWarn (Reason flag) $ vcat
[ text "Noncanonical" <+>
quotes (text (lhs ++ " = " ++ rhs)) <+>
......@@ -536,29 +539,26 @@ checkCanonicalInstances cls poly_ty mbinds = do
, text "Move definition from" <+>
quotes (text rhs) <+>
text "to" <+> quotes (text lhs)
, text "See also:" <+>
text refURL
]
-- expected "lhs = rhs" but got something else
addWarnNonCanonicalMethod2 flag lhs rhs = do
addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
addWarn (Reason flag) $ vcat
[ text "Noncanonical" <+>
quotes (text lhs) <+>
text "definition detected"
, instDeclCtxt1 poly_ty
, quotes (text lhs) <+>
text "will eventually be removed in favour of" <+>
quotes (text rhs)
, text "Either remove definition for" <+>
quotes (text lhs) <+> text "or define as" <+>
quotes (text (lhs ++ " = " ++ rhs))
]
-- like above, but method has no default impl
addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
addWarn (Reason flag) $ vcat
[ text "Noncanonical" <+>
quotes (text lhs) <+>
text "definition detected"
, instDeclCtxt1 poly_ty
, text "Define as" <+>
quotes (text lhs) <+> text "(recommended)" <+>
text "or define as" <+>
quotes (text (lhs ++ " = " ++ rhs))
, text "See also:" <+>
text refURL
]
-- stolen from GHC.Tc.TyCl.Instance
......
......@@ -243,6 +243,10 @@ Compiler
- A new flag :ghc-flag:`-flink-rts` to enable linking the RTS when linking
shared libraries.
- The :ghc-flag:`-Wnoncanonical-monad-instances` and
:ghc-flag:`-Wnoncanonical-monoid-instances` warnings are now enabled by
default, as proposed in `GHC proposal #314
<https://github.com/ghc-proposals/ghc-proposals/pull/314>`_
GHCi
~~~~
......
......@@ -82,11 +82,10 @@ instance Functor CompPipeline where
fmap = liftM
instance Applicative CompPipeline where
pure = return
pure a = P $ \state -> return (state, a)
(<*>) = ap
instance Monad CompPipeline where
return a = P $ \state -> return (state, a)
P m >>= k = P $ \state -> do (state',a) <- m state
unP (k a) state'
......
......@@ -25,7 +25,7 @@ instance Functor (StateTrans s) where
fmap = liftM
instance Applicative (StateTrans s) where
pure = return
pure v= ST (\s -> (s, Just v))
(<*>) = ap
instance Monad (StateTrans s) where
......@@ -40,8 +40,6 @@ instance Monad (StateTrans s) where
q s1
Nothing -> (s1, Nothing)
)
return v
= ST (\s -> (s, Just v))
-- machine state transitions
......
......@@ -22,11 +22,10 @@ instance Functor (State s) where
fmap = liftM
instance Applicative (State s) where
pure = return
pure a = State $ \s -> (a, s)
(<*>) = ap
instance Monad (State s) where
return a = State $ \s -> (a, s)
m >>= k = State $ \s -> let
(a, s') = runState m s
in runState (k a) s'
......
......@@ -40,7 +40,6 @@ newtype StateT s m a = StateT
{ runStateT :: s -> m (a, s) }
instance MonadFix m => Monad (StateT s m) where
return x = StateT $ \s -> pure (x, s)
m >>= f = StateT $ \s -> do
rec
(x, s'') <- runStateT m s'
......@@ -49,7 +48,7 @@ instance MonadFix m => Monad (StateT s m) where
instance MonadFix m => Applicative (StateT s m) where
(<*>) = ap
pure = return
pure x = StateT $ \s -> pure (x, s)
instance Functor m => Functor (StateT s m) where
-- this instance is hand-written
......
......@@ -30,28 +30,26 @@ instance Functor (M s) where
fmap = liftM
instance Applicative (M s) where
pure = return
pure x = M (return (Ok x))
(<*>) = ap
instance Monad (M s) where
instance Monad (M s) where
return x = M (return (Ok x))
{- this one gives a type error in 6.4.1 -}
M m >>= k = M (do res <- m
case res of
case res of
Ok x -> unM (k x)
Fail -> return Fail
)
)
{- while this one works -}
{- while this one works -}
-- M m >>= k = M (f m (unM . k))
-- where
-- where
-- f :: IO (Result s a) -> (a -> IO (Result s b)) -> IO (Result s b)
-- f m k = do res <- m
-- case res of
-- Ok x -> k x
-- Fail -> return Fail
......@@ -94,11 +94,10 @@ instance Functor Tree where
fmap = liftM
instance Applicative Tree where
pure = return
pure = Val
(<*>) = ap
instance Monad Tree where
return x = Val x
(Val a) >>= f = f a
(Choice l r) >>= f = Choice (l >>= f) (r >>= f)
......
......@@ -173,13 +173,13 @@ instance Functor HappyIdentity where
fmap = liftM
instance Applicative HappyIdentity where
pure = return
pure = HappyIdentity
(<*>) = ap
instance Monad HappyIdentity where
return = HappyIdentity
(HappyIdentity p) >>= q = q p
happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
happyThen = (>>=)
happyReturn :: () => a -> HappyIdentity a
......
:set -XTemplateHaskell
Language.Haskell.TH.runQ [d| instance Monad ((,) a) where { return = undefined; (>>=) = undefined } |]
Language.Haskell.TH.runQ [d| instance Monad ((,) a) where { (>>=) = undefined } |]
[InstanceD Nothing [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.(,)) (VarT a_0))) [ValD (VarP GHC.Base.return) (NormalB (VarE GHC.Err.undefined)) [],ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]]
[InstanceD Nothing [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.(,)) (VarT a_0))) [ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]]
\ No newline at end of file
......@@ -14,7 +14,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is not enabled
......@@ -37,7 +36,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should work, GADTs is in force from :set
......@@ -59,7 +57,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is now disabled
......@@ -83,7 +80,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is only enabled at the prompt
......
......@@ -15,7 +15,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
~~~~~~~~~~ Testing :set -a
......
......@@ -14,7 +14,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is not enabled
......@@ -37,7 +36,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should work, GADTs is in force from :set
......@@ -59,7 +57,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is now disabled
......@@ -83,7 +80,6 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
warning settings:
-Wsemigroup
-Wnoncanonical-monoid-instances
-Wstar-is-type
-Wcompat-unqualified-imports
Should fail, GADTs is only enabled at the prompt
......
......@@ -19,11 +19,10 @@ instance Functor X where
fmap = liftM
instance Applicative X where
pure = return
pure = X
(<*>) = ap
instance Monad X where
return = X
(X a) >>= f = f a
z :: X [Int]
......
......@@ -13,7 +13,6 @@ instance Applicative (NukeMonad a b) where
(<*>) = undefined
instance Monad (NukeMonad a b) where
return = undefined
(>>=) = undefined
......
......@@ -25,7 +25,6 @@ instance Monad m => Applicative (CondT a m) where
(<*>) = undefined
instance Monad m => Monad (CondT a m) where
return = undefined
(>>=) = undefined
-- liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
......@@ -15,7 +15,6 @@ instance Applicative f => Applicative (ReaderT r f) where
f <*> v = ReaderT $ \r -> runReaderT f r <*> runReaderT v r
instance (Monad m) => Monad (ReaderT r m) where
return a = ReaderT $ \_ -> return a
m >>= k = ReaderT $ \r -> do
a <- runReaderT m r
runReaderT (k a) r
......
......@@ -16,19 +16,18 @@ instance Prelude.Functor Identity where
fmap = liftM
instance Applicative Identity where
pure = Prelude.return
pure = Identity
(<*>) = ap
instance Prelude.Monad Identity where
return a = Identity a
m >>= k = k (runIdentity m)
class Bind m1 m2 m3 | m1 m2 -> m3 where
class Bind m1 m2 m3 | m1 m2 -> m3 where
(>>=) :: m1 a -> (a -> m2 b) -> m3 b
class Return m where
returnM :: a -> m a
fail :: String -> m a
fail :: String -> m a
instance Bind Maybe [] [] where
Just x >>= f = f x
......@@ -39,15 +38,15 @@ instance Functor a => Bind a Identity a where m >>= f = fmap (runIdentity . f)
instance Prelude.Monad m => Bind m m m where (>>=) = (Prelude.>>=)
instance Return [] where
instance Return [] where
returnM x = [x]
fail _ = []
fail _ = []
return :: a -> Identity a
return = Prelude.return
should_compile :: [Int]
should_compile = do
should_compile = do
a <- Just 1
b <- [a*1,a*2]
return (b+1)
\ No newline at end of file
......@@ -3,7 +3,7 @@
-- Helper for simpl009.hs (see comments there)
module Simpl009Help where
import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad
......@@ -19,12 +19,12 @@ instance Functor (Parser s) where
fmap = liftM
instance Applicative (Parser s) where
pure = return
pure a = Parser (\fut -> fut a)
(<*>) = ap
instance Monad (Parser s) where
return a = Parser (\fut -> fut a)
Parser f >>= k =
Parser (\fut -> f (\a -> let Parser g = k a in g fut))
......
......@@ -20,11 +20,10 @@ instance Functor Eval where
fmap = liftM
instance Applicative Eval where
pure = return
pure = Done
(<*>) = ap
instance Monad Eval where
return x = Done x
Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict
rpar :: a -> Eval a
......
......@@ -13,11 +13,10 @@ instance Functor (ReaderT r) where
instance Applicative (ReaderT r) where
pure = liftReaderT . pure
f <*> v = undefined
m *> k = ReaderT $ \r -> do runReaderT m r; runReaderT k r
instance Monad (ReaderT r) where
return = liftReaderT . return
m >>= k = undefined
m >> k = ReaderT $ \r -> do runReaderT m r; runReaderT k r
liftReaderT :: IO a -> ReaderT r a
liftReaderT m = ReaderT (const m)
......
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
-- This test has a deep nest of join points, which led to
-- This test has a deep nest of join points, which led to
-- an exponential blow-up in GHC.Core.Opt.SpecConstr
module T3831(setAttributes) where
......@@ -24,11 +24,10 @@ instance Functor Capability where
fmap = liftM
instance Applicative Capability where
pure = return
pure = Capability . const . return . Just
(<*>) = ap
instance Monad Capability where
return = Capability . const . return . Just
Capability f >>= g = Capability $ \t -> do
mx <- f t
case mx of
......
......@@ -32,11 +32,10 @@ instance Functor Gen where
fmap = liftM
instance Applicative Gen where
pure = return
pure = Gen
(<*>) = ap
instance Monad Gen where
return a = Gen a
Gen m >>= k = Gen (let Gen m' = k m in m')
class Arbitrary a where
......
......@@ -19,7 +19,6 @@ instance (Functor m) => Functor (ReaderT r m) where
fmap f = mapReaderT (fmap f)
instance (Monad m) => Monad (ReaderT r m) where
return x = ReaderT (\_ -> return x)
m >>= k = ReaderT $ \ r -> do
a <- runReaderT m r
runReaderT (k a) r
......
......@@ -8,19 +8,18 @@ module T3955 where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
class (Monad m) => MonadReader r m
class (Monad m) => MonadReader r m
newtype Reader r a = Reader { runReader :: r -> a }
instance Functor (Reader r) where
fmap = liftM
instance Applicative (Reader r) where
pure = return
pure = error "urk"
(<*>) = ap
instance Monad (Reader r) where
(>>=) = error "urk"
return = error "urk"
instance MonadReader r (Reader r)
......
......@@ -31,7 +31,6 @@ instance Applicative (M m) where
instance Monad m => Monad (M m) where
(>>=) = undefined
return = undefined
instance MonadError e m => MonadError e (M m)
......
......@@ -11,11 +11,10 @@ instance Functor (WrapIO e) where
fmap = liftM
instance Applicative (WrapIO e) where
pure = return
pure x = MkWrapIO (return x)
(<*>) = ap
instance Monad (WrapIO e) where
return x = MkWrapIO (return x)
m >>= f = MkWrapIO (do x <- unwrap m
unwrap (f x) )
......
......@@ -13,19 +13,18 @@ unitState a = State (\s0 -> (a,s0))
bindState :: State c a -> (a -> State c b) -> State c b
bindState m k = State (\s0 -> let (a,s1) = (unState m) s0
(b,s2) = (unState (k a)) s1
(b,s2) = (unState (k a)) s1
in (b,s2))
instance Eq c => Functor (State c) where
fmap = liftM
instance Eq c => Applicative (State c) where
pure = return
pure = unitState
(<*>) = ap
instance Eq c => Monad (State c) where
return = unitState
(>>=) = bindState
(>>=) = bindState
data TS = TS { vs::Int } deriving (Show,Eq)
......
......@@ -19,7 +19,6 @@ instance Applicative (L m) where
instance Monad m => Monad (L m) where
(>>=) = undefined
return = undefined
zork :: (Monad m) => a -> L m ()
zork = undefined
......
......@@ -3,15 +3,18 @@ Template.hs:7:1: warning: [-Wsemigroup (in -Wcompat)]
Local definition of ‘<>’ clashes with a future Prelude name.
This will become an error in a future release.
Template.hs:13:3: warning: [-Wnoncanonical-monoid-instances (in -Wcompat)]
Template.hs:13:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)]
Noncanonical ‘(<>) = mappend’ definition detected
in the instance declaration for ‘Semigroup S’.
Move definition from ‘mappend’ to ‘(<>)’
See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid
Template.hs:16:3: warning: [-Wnoncanonical-monoid-instances (in -Wcompat)]
Template.hs:16:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)]
Noncanonical ‘mappend’ definition detected
in the instance declaration for ‘Monoid S’.
Define as ‘mappend = (<>)’
‘mappend’ will eventually be removed in favour of ‘(<>)’
Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’
See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid
Template.hs:20:15: warning: [-Wstar-is-type (in -Wall, -Wcompat)]
Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
......
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