From 994bda563604461ffb8454d6e298b0310520bcc8 Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Fri, 28 Apr 2023 16:03:29 +0200
Subject: Add structured error messages for GHC.Rename.Module

Tracking ticket: #20115

MR: !10361

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

Only addresses the single warning missing from the previous MR.
---
 testsuite/tests/mdo/should_compile/mdo002.hs       |  3 +-
 testsuite/tests/polykinds/MonoidsFD.hs             |  7 ++--
 testsuite/tests/polykinds/MonoidsTF.hs             |  3 +-
 testsuite/tests/profiling/should_run/T3001-2.hs    | 19 ++++------
 testsuite/tests/profiling/should_run/ioprof.hs     |  4 +-
 testsuite/tests/rebindable/rebindable2.hs          |  9 ++---
 testsuite/tests/rebindable/rebindable2.stdout      | 12 +++---
 testsuite/tests/simplCore/T9646/StrictPrim.hs      | 10 ++---
 testsuite/tests/simplCore/should_run/T17744A.hs    |  3 +-
 testsuite/tests/simplCore/should_run/T3591.hs      | 14 +++----
 .../tests/typecheck/should_run/T1735_Help/State.hs |  3 +-
 .../tests/typecheck/should_run/T4809_IdentityT.hs  |  3 +-
 .../typecheck/should_run/T4809_XMLGenerator.hs     |  9 ++---
 testsuite/tests/wcompat-warnings/Template.hs       | 15 ++++++++
 .../wcompat-warnings/WCompatWarningsOn.stderr      | 44 +++++++++++++++++++---
 15 files changed, 94 insertions(+), 64 deletions(-)

(limited to 'testsuite/tests')

diff --git a/testsuite/tests/mdo/should_compile/mdo002.hs b/testsuite/tests/mdo/should_compile/mdo002.hs
index 3f9533f247..19e63bffc9 100644
--- a/testsuite/tests/mdo/should_compile/mdo002.hs
+++ b/testsuite/tests/mdo/should_compile/mdo002.hs
@@ -13,11 +13,10 @@ instance Functor X where
   fmap f (X a) = X (f a)
 
 instance Applicative X where
-  pure  = return
+  pure  = X
   (<*>) = ap
 
 instance Monad X where
-  return      = X
   (X a) >>= f = f a
 
 instance MonadFix X where
diff --git a/testsuite/tests/polykinds/MonoidsFD.hs b/testsuite/tests/polykinds/MonoidsFD.hs
index 67be60d60a..1c3ea33cce 100644
--- a/testsuite/tests/polykinds/MonoidsFD.hs
+++ b/testsuite/tests/polykinds/MonoidsFD.hs
@@ -25,7 +25,7 @@ class Monoidy to comp id m | m to → comp id where
 
 -- We use functional dependencies to help the typechecker understand that
 -- m and ~> uniquely determine comp (times) and id.
--- 
+--
 -- This kind of type class would not have been possible in previous
 -- versions of GHC; with the new kind system, however, we can abstract
 -- over kinds!2 Now, let’s create types for the additive and
@@ -89,18 +89,17 @@ instance Monoidy (→) (,) () m ⇒ Monoid m where
   mempty = munit ()
 
 instance Applicative Wrapper where
-  pure  = return
+  pure x = runNT munit $ Id x
   (<*>) = ap
 
 -- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where
 instance Monad Wrapper where
-   return x = runNT munit $ Id x
    x >>= f = runNT mjoin $ FC (f `fmap` x)
 
 -- And so the following works:
 
 test3
- = do { print (mappend mempty (Sum 2))  
+ = do { print (mappend mempty (Sum 2))
              -- Sum 2
       ; print (mappend (Product 2) (Product 3))
              -- Product 6
diff --git a/testsuite/tests/polykinds/MonoidsTF.hs b/testsuite/tests/polykinds/MonoidsTF.hs
index 8e3b378046..327ae08bea 100644
--- a/testsuite/tests/polykinds/MonoidsTF.hs
+++ b/testsuite/tests/polykinds/MonoidsTF.hs
@@ -103,11 +103,10 @@ instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m)
   mempty = munit ()
 
 instance Applicative Wrapper where
-  pure  = return
+  pure x = runNT munit $ Id x
   (<*>) = ap
 
 instance Monad Wrapper where
-  return x = runNT munit $ Id x
   x >>= f = runNT mjoin $ FC (f `fmap` x)
 
 -- And so the following works:
diff --git a/testsuite/tests/profiling/should_run/T3001-2.hs b/testsuite/tests/profiling/should_run/T3001-2.hs
index 3767073cc3..79b3729e89 100644
--- a/testsuite/tests/profiling/should_run/T3001-2.hs
+++ b/testsuite/tests/profiling/should_run/T3001-2.hs
@@ -90,22 +90,20 @@ instance Functor PutM where
         fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
 
 instance Monad PutM where
-    return a = Put $ PairS a mempty
-
     m >>= k  = Put $
         let PairS a w  = unPut m
             PairS b w' = unPut (k a)
         in PairS b (w `mappend` w')
 
-    m >> k  = Put $
+instance Applicative PutM where
+    pure a = Put $ PairS a mempty
+    (<*>) = ap
+
+    m *> k  = Put $
         let PairS _ w  = unPut m
             PairS b w' = unPut k
         in PairS b (w `mappend` w')
 
-instance Applicative PutM where
-    pure  = return
-    (<*>) = ap
-
 tell :: Builder -> Put
 tell b = Put $ PairS () b
 
@@ -189,9 +187,6 @@ joinZ bb lb
     | otherwise = L.Chunk bb lb
 
 instance Monad Get where
-    return a  = Get (\s -> (a, s))
-    {-# INLINE return #-}
-
     m >>= k   = Get (\s -> let (a, s') = unGet m s
                            in unGet (k a) s')
     {-# INLINE (>>=) #-}
@@ -200,7 +195,9 @@ instance MonadFail Get where
     fail      = error "failDesc"
 
 instance Applicative Get where
-    pure  = return
+    pure a  = Get (\s -> (a, s))
+    {-# INLINE pure #-}
+
     (<*>) = ap
 
 getZ :: Get S
diff --git a/testsuite/tests/profiling/should_run/ioprof.hs b/testsuite/tests/profiling/should_run/ioprof.hs
index 98c7f4e241..4df7899a44 100644
--- a/testsuite/tests/profiling/should_run/ioprof.hs
+++ b/testsuite/tests/profiling/should_run/ioprof.hs
@@ -10,13 +10,13 @@ newtype M s a = M { unM :: s -> (s,a) }
 instance Monad (M s) where
   (M m) >>= k = M $ \s -> case m s of
                             (s',a) -> unM (k a) s'
-  return a = M $ \s -> (s,a)
+
 
 instance Functor (M s) where
     fmap = liftM
 
 instance Applicative (M s) where
-    pure  = return
+    pure a = M $ \s -> (s,a)
     (<*>) = ap
 
 errorM :: String -> M s a
diff --git a/testsuite/tests/rebindable/rebindable2.hs b/testsuite/tests/rebindable/rebindable2.hs
index 5729c4ef34..ff4d6ac6cc 100644
--- a/testsuite/tests/rebindable/rebindable2.hs
+++ b/testsuite/tests/rebindable/rebindable2.hs
@@ -24,16 +24,15 @@ module Main where
           };
         instance (Applicative TM) where
           {
-            pure  = return;
+            pure a = MkTM (debugFunc "pure" (Prelude.pure a));
+            (*>) ma mb = MkTM (debugFunc "*>" ((Prelude.*>) (unTM ma) (unTM mb)));
             (<*>) = ap;
           };
         instance (Monad TM) where
                 {
-                return a = MkTM (debugFunc "return" (Prelude.return a));
-
+                return = pure;
                 (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a))));
-
-                (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb)));
+                (>>) = (*>)
                 };
         instance (MonadFail TM) where
                 {
diff --git a/testsuite/tests/rebindable/rebindable2.stdout b/testsuite/tests/rebindable/rebindable2.stdout
index 970af0f0ab..8712df51e7 100644
--- a/testsuite/tests/rebindable/rebindable2.stdout
+++ b/testsuite/tests/rebindable/rebindable2.stdout
@@ -1,18 +1,18 @@
 start test test_do failure
-++ >>
+++ *>
 ++ >>=
 ++ fail
 -- fail
 -- >>=
--- >>
+-- *>
 end test test_do failure
 start test test_do success
-++ >>
+++ *>
 ++ >>=
-++ return
--- return
+++ pure
+-- pure
 -- >>=
--- >>
+-- *>
 end test test_do success
 start test test_fromInteger
 135
diff --git a/testsuite/tests/simplCore/T9646/StrictPrim.hs b/testsuite/tests/simplCore/T9646/StrictPrim.hs
index 5b83f2fcf1..e85e11e6fc 100644
--- a/testsuite/tests/simplCore/T9646/StrictPrim.hs
+++ b/testsuite/tests/simplCore/T9646/StrictPrim.hs
@@ -18,7 +18,10 @@ newtype StrictPrim s a
 
 instance Applicative (StrictPrim s) where
     {-# INLINE pure #-}
-    pure = return
+    pure !x = StrictPrim ( \ !s -> (# s, x #))
+
+    {-# INLINE (*>) #-}
+    (!m) *> (!k) = do { _ <- m ;  k }
 
     {-# INLINE (<*>) #-}
     (<*>) a b = do f <- a ; v <- b ; return $! (f $! v)
@@ -31,11 +34,6 @@ instance Functor (StrictPrim s) where
 
 
 instance Monad (StrictPrim s) where
-    {-# INLINE return #-}
-    return !x = StrictPrim ( \ !s -> (# s, x #))
-
-    {-# INLINE (>>) #-}
-    (!m) >> (!k) = do { _ <- m ;  k }
 
     {-# INLINE (>>=) #-}
     (StrictPrim !m) >>= (!k) =
diff --git a/testsuite/tests/simplCore/should_run/T17744A.hs b/testsuite/tests/simplCore/should_run/T17744A.hs
index 69e18f0ea4..63868a8573 100644
--- a/testsuite/tests/simplCore/should_run/T17744A.hs
+++ b/testsuite/tests/simplCore/should_run/T17744A.hs
@@ -17,10 +17,9 @@ instance Functor (Parser t) where
    fmap f p = apply (fmap f) p
 
 instance Applicative (Parser t) where
-   pure = return
+   pure = Result mempty
 
 instance Monad (Parser t) where
-   return = Result mempty
    Result s r >>= f = feed s (f r)
    p >>= f = apply (>>= f) p
 
diff --git a/testsuite/tests/simplCore/should_run/T3591.hs b/testsuite/tests/simplCore/should_run/T3591.hs
index 09724fef62..b1950e81e3 100644
--- a/testsuite/tests/simplCore/should_run/T3591.hs
+++ b/testsuite/tests/simplCore/should_run/T3591.hs
@@ -1,4 +1,4 @@
-{- 
+{-
     Copyright 2009 Mario Blazevic
 
     This file is part of the Streaming Component Combinators (SCC) project.
@@ -20,7 +20,7 @@
 -- | Module "Trampoline" defines the pipe computations and their basic building blocks.
 
 {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
-             TypeFamilies, KindSignatures, FlexibleContexts, 
+             TypeFamilies, KindSignatures, FlexibleContexts,
              FlexibleInstances, OverlappingInstances, UndecidableInstances
  #-}
 
@@ -75,11 +75,10 @@ instance Functor Identity where
     fmap = liftM
 
 instance Applicative Identity where
-    pure  = return
+    pure a = Identity a
     (<*>) = ap
 
 instance Monad Identity where
-    return a = Identity a
     m >>= k  = k (runIdentity m)
 
 newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
@@ -89,11 +88,10 @@ instance (Monad m, Functor s) => Functor (Trampoline m s) where
   fmap = liftM
 
 instance (Monad m, Functor s) => Applicative (Trampoline m s) where
-  pure  = return
+  pure x = Trampoline (return (Done x))
   (<*>) = ap
 
 instance (Monad m, Functor s) => Monad (Trampoline m s) where
-   return x = Trampoline (return (Done x))
    t >>= f = Trampoline (bounce t >>= apply f)
       where apply f (Done x) = bounce (f x)
             apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
@@ -111,7 +109,7 @@ instance Functor (Await x) where
 
 data EitherFunctor l r x = LeftF (l x) | RightF (r x)
 instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
-   fmap f v = trace "fmap Either" $ 
+   fmap f v = trace "fmap Either" $
               case v of
                 LeftF l  -> trace "fmap LeftF" $ LeftF (fmap f l)
                 RightF r -> trace "fmap RightF" $ RightF (fmap f r)
@@ -178,7 +176,7 @@ liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoli
 liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
    where inject :: TrampolineState m a x -> TrampolineState m d x
          inject (Done x) = Done x
-         inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ 
+         inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $
                               fmap liftOut (trace "poking a" a))
 
 data Sink (m :: Type -> Type) a x =
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/State.hs b/testsuite/tests/typecheck/should_run/T1735_Help/State.hs
index 093a7e2c81..d3d9f6a879 100644
--- a/testsuite/tests/typecheck/should_run/T1735_Help/State.hs
+++ b/testsuite/tests/typecheck/should_run/T1735_Help/State.hs
@@ -7,7 +7,6 @@ import Control.Monad (ap, liftM)
 newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
 
 instance Monad m => Monad (StateT s m) where
-    return a = StateT $ \s -> return (a, s)
     m >>= k  = StateT $ \s -> do
         ~(a, s') <- runStateT m s
         runStateT (k a) s'
@@ -19,7 +18,7 @@ instance Monad m => Functor (StateT s m) where
     fmap = liftM
 
 instance Monad m => Applicative (StateT s m) where
-    pure  = return
+    pure a = StateT $ \s -> pure (a, s)
     (<*>) = ap
 
 get :: Monad m => StateT s m s
diff --git a/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs b/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs
index 0289dec5ad..50202a9705 100644
--- a/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs
+++ b/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs
@@ -19,9 +19,8 @@ data XML
 -- * IdentityT Monad Transformer
 
 newtype IdentityT m a = IdentityT { runIdentityT :: m a }
-    deriving (Functor, Monad, MonadIO, MonadPlus)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadPlus)
 
-instance Monad m => Applicative (IdentityT m) where
 instance Monad m => Alternative (IdentityT m) where
 
 instance MonadTrans IdentityT where
diff --git a/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs b/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs
index ca4dcfeb0f..a2a671bdfc 100644
--- a/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs
+++ b/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs
@@ -34,12 +34,9 @@ import Control.Monad (MonadPlus(..),liftM)
 
 -- | The monad transformer that allows a monad to generate XML values.
 newtype XMLGenT m a = XMLGenT (m a)
-  deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
-            MonadState s, MonadRWS r w s, MonadCont, MonadError e)
-
-instance Monad m => Applicative (XMLGenT m) where
-  pure  = return
-  (<*>) = ap
+  deriving (Monad, Functor, Applicative, MonadIO, MonadPlus, MonadWriter w,
+            MonadReader r, MonadState s, MonadRWS r w s, MonadCont,
+            MonadError e)
 
 instance Monad m => Alternative (XMLGenT m) where
 
diff --git a/testsuite/tests/wcompat-warnings/Template.hs b/testsuite/tests/wcompat-warnings/Template.hs
index 2a9a11b0c4..86c1449c64 100644
--- a/testsuite/tests/wcompat-warnings/Template.hs
+++ b/testsuite/tests/wcompat-warnings/Template.hs
@@ -13,3 +13,18 @@ instance Semi.Semigroup S where
 instance Monoid S where
   S a `mappend` S b = S (a+b)
   mempty = S 0
+
+newtype M a = M a
+
+instance Functor M where
+  fmap = undefined
+
+instance Applicative M where
+  liftA2 = undefined
+  pure = return
+  (*>) = (>>)
+
+instance Monad M where
+  return = undefined
+  (>>=) = undefined
+  (>>) = undefined
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
index aaf0772b41..75df49fd36 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
@@ -3,15 +3,47 @@ Template.hs:5: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:11:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)]
+Template.hs:11:3: warning: [GHC-50928] [-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
+    Suggested fix:
+      Move definition from ‘mappend’ to ‘(<>)’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid
 
-Template.hs:14:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)]
+Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)]
     Noncanonical ‘mappend’ definition detected
     in the instance declaration for ‘Monoid S’.
     ‘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
+    Suggested fix:
+      Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid
+
+Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)]
+    Noncanonical ‘pure = return’ definition detected
+    in the instance declaration for ‘Applicative M’.
+    Suggested fix:
+      Move definition from ‘return’ to ‘pure’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return
+
+Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)]
+    Noncanonical ‘(*>) = (>>)’ definition detected
+    in the instance declaration for ‘Applicative M’.
+    Suggested fix:
+      Move definition from ‘(>>)’ to ‘(*>)’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return
+
+Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)]
+    Noncanonical ‘return’ definition detected
+    in the instance declaration for ‘Monad M’.
+    ‘return’ will eventually be removed in favour of ‘pure’
+    Suggested fix:
+      Either remove definition for ‘return’ (recommended) or define as ‘return = pure’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return
+
+Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)]
+    Noncanonical ‘(>>)’ definition detected
+    in the instance declaration for ‘Monad M’.
+    ‘(>>)’ will eventually be removed in favour of ‘(*>)’
+    Suggested fix:
+      Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’
+      See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return
-- 
cgit v1.2.1