[Git][ghc/ghc][master] Add structured error messages for GHC.Rename.Module
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 6 02:05:31 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00
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.
- - - - -
23 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- docs/users_guide/using-warnings.rst
- testsuite/tests/mdo/should_compile/mdo002.hs
- testsuite/tests/polykinds/MonoidsFD.hs
- testsuite/tests/polykinds/MonoidsTF.hs
- testsuite/tests/profiling/should_run/T3001-2.hs
- testsuite/tests/profiling/should_run/ioprof.hs
- testsuite/tests/rebindable/rebindable2.hs
- testsuite/tests/rebindable/rebindable2.stdout
- testsuite/tests/simplCore/T9646/StrictPrim.hs
- testsuite/tests/simplCore/should_run/T17744A.hs
- testsuite/tests/simplCore/should_run/T3591.hs
- testsuite/tests/typecheck/should_run/T1735_Help/State.hs
- testsuite/tests/typecheck/should_run/T4809_IdentityT.hs
- testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs
- testsuite/tests/wcompat-warnings/Template.hs
- testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -929,6 +929,7 @@ minusWcompatOpts :: [WarningFlag]
minusWcompatOpts
= [ Opt_WarnSemigroup
, Opt_WarnNonCanonicalMonoidInstances
+ , Opt_WarnNonCanonicalMonadInstances
, Opt_WarnCompatUnqualifiedImports
, Opt_WarnTypeEqualityOutOfScope
]
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -22,7 +22,6 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
-import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.HsType
@@ -452,11 +451,9 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances cls poly_ty mbinds = do
whenWOptM Opt_WarnNonCanonicalMonadInstances
$ checkCanonicalMonadInstances
- "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
whenWOptM Opt_WarnNonCanonicalMonoidInstances
$ checkCanonicalMonoidInstances
- "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
where
-- Warn about unsound/non-canonical 'Applicative'/'Monad' instance
@@ -472,19 +469,17 @@ checkCanonicalInstances cls poly_ty mbinds = do
-- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
-- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
--
- checkCanonicalMonadInstances refURL
+ checkCanonicalMonadInstances
| cls == applicativeClassName =
forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
case mbind of
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == pureAName, isAliasMG mg == Just returnMName
- -> addWarnNonCanonicalMethod1 refURL
- Opt_WarnNonCanonicalMonadInstances "pure" "return"
+ -> addWarnNonCanonicalMonad NonCanonical_Pure
| name == thenAName, isAliasMG mg == Just thenMName
- -> addWarnNonCanonicalMethod1 refURL
- Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
+ -> addWarnNonCanonicalMonad NonCanonical_ThenA
_ -> return ()
@@ -494,12 +489,10 @@ checkCanonicalInstances cls poly_ty mbinds = do
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == returnMName, isAliasMG mg /= Just pureAName
- -> addWarnNonCanonicalMethod2 refURL
- Opt_WarnNonCanonicalMonadInstances "return" "pure"
+ -> addWarnNonCanonicalMonad NonCanonical_Return
| name == thenMName, isAliasMG mg /= Just thenAName
- -> addWarnNonCanonicalMethod2 refURL
- Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
+ -> addWarnNonCanonicalMonad NonCanonical_ThenM
_ -> return ()
@@ -518,15 +511,14 @@ checkCanonicalInstances cls poly_ty mbinds = do
--
-- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
--
- checkCanonicalMonoidInstances refURL
+ checkCanonicalMonoidInstances
| cls == semigroupClassName =
forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
case mbind of
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == sappendName, isAliasMG mg == Just mappendName
- -> addWarnNonCanonicalMethod1 refURL
- Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
+ -> addWarnNonCanonicalMonoid NonCanonical_Sappend
_ -> return ()
@@ -536,9 +528,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
FunBind { fun_id = L _ name
, fun_matches = mg }
| name == mappendName, isAliasMG mg /= Just sappendName
- -> addWarnNonCanonicalMethod2 refURL
- Opt_WarnNonCanonicalMonoidInstances
- "mappend" "(<>)"
+ -> addWarnNonCanonicalMonoid NonCanonical_Mappend
_ -> return ()
@@ -554,51 +544,14 @@ checkCanonicalInstances cls poly_ty mbinds = do
, HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName)
isAliasMG _ = Nothing
- -- got "lhs = rhs" but expected something different
- addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
- let dia = mkTcRnUnknownMessage $
- mkPlainDiagnostic (WarningWithFlag flag) noHints $
- 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)
- , text "See also:" <+>
- text refURL
- ]
- addDiagnostic dia
-
- -- expected "lhs = rhs" but got something else
- addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
- let dia = mkTcRnUnknownMessage $
- mkPlainDiagnostic (WarningWithFlag flag) noHints $
- 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 "(recommended)" <+>
- text "or define as" <+>
- quotes (text (lhs ++ " = " ++ rhs))
- , text "See also:" <+>
- text refURL
- ]
- addDiagnostic dia
-
- -- stolen from GHC.Tc.TyCl.Instance
- instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
- instDeclCtxt1 hs_inst_ty
- = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
-
- inst_decl_ctxt :: SDoc -> SDoc
- inst_decl_ctxt doc = hang (text "in the instance declaration for")
- 2 (quotes doc <> text ".")
+ addWarnNonCanonicalMonoid reason =
+ addWarnNonCanonicalDefinition (NonCanonicalMonoid reason)
+ addWarnNonCanonicalMonad reason =
+ addWarnNonCanonicalDefinition (NonCanonicalMonad reason)
+
+ addWarnNonCanonicalDefinition reason =
+ addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty)
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1859,6 +1859,9 @@ instance Diagnostic TcRnMessage where
locations =
text "Bound at:"
<+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs)))
+ TcRnNonCanonicalDefinition reason inst_ty
+ -> mkSimpleDecorated $
+ pprNonCanonicalDefinition inst_ty reason
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2484,6 +2487,11 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnBindingNameConflict{}
-> ErrorWithoutFlag
+ TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _
+ -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances
+ TcRnNonCanonicalDefinition (NonCanonicalMonad _) _
+ -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances
+
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3145,6 +3153,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnBindingNameConflict{}
-> noHints
+ TcRnNonCanonicalDefinition reason _
+ -> suggestNonCanonicalDefinition reason
diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode
diagnosticCode = constructorCode
@@ -5451,3 +5461,78 @@ pprAmbiguousGreName gre
| otherwise
= pprPanic "addNameClassErrRn" (ppr gre)
-- Invariant: either 'lcl' is True or 'iss' is non-empty
+
+pprNonCanonicalDefinition :: LHsSigType GhcRn
+ -> NonCanonicalDefinition
+ -> SDoc
+pprNonCanonicalDefinition inst_ty = \case
+ NonCanonicalMonoid sub -> case sub of
+ NonCanonical_Sappend ->
+ msg1 "(<>)" "mappend"
+ NonCanonical_Mappend ->
+ msg2 "mappend" "(<>)"
+ NonCanonicalMonad sub -> case sub of
+ NonCanonical_Pure ->
+ msg1 "pure" "return"
+ NonCanonical_ThenA ->
+ msg1 "(*>)" "(>>)"
+ NonCanonical_Return ->
+ msg2 "return" "pure"
+ NonCanonical_ThenM ->
+ msg2 "(>>)" "(*>)"
+ where
+ msg1 :: String -> String -> SDoc
+ msg1 lhs rhs =
+ vcat [ text "Noncanonical" <+>
+ quotes (text (lhs ++ " = " ++ rhs)) <+>
+ text "definition detected"
+ , inst
+ ]
+
+ msg2 :: String -> String -> SDoc
+ msg2 lhs rhs =
+ vcat [ text "Noncanonical" <+>
+ quotes (text lhs) <+>
+ text "definition detected"
+ , inst
+ , quotes (text lhs) <+>
+ text "will eventually be removed in favour of" <+>
+ quotes (text rhs)
+ ]
+
+ inst = instDeclCtxt1 inst_ty
+
+ -- stolen from GHC.Tc.TyCl.Instance
+ instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+ instDeclCtxt1 hs_inst_ty
+ = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+ inst_decl_ctxt :: SDoc -> SDoc
+ inst_decl_ctxt doc = hang (text "in the instance declaration for")
+ 2 (quotes doc <> text ".")
+
+suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint]
+suggestNonCanonicalDefinition reason =
+ [action doc]
+ where
+ action = case reason of
+ NonCanonicalMonoid sub -> case sub of
+ NonCanonical_Sappend -> move sappendName mappendName
+ NonCanonical_Mappend -> remove mappendName sappendName
+ NonCanonicalMonad sub -> case sub of
+ NonCanonical_Pure -> move pureAName returnMName
+ NonCanonical_ThenA -> move thenAName thenMName
+ NonCanonical_Return -> remove returnMName pureAName
+ NonCanonical_ThenM -> remove thenMName thenAName
+
+ move = SuggestMoveNonCanonicalDefinition
+ remove = SuggestRemoveNonCanonicalDefinition
+
+ doc = case reason of
+ NonCanonicalMonoid _ -> doc_monoid
+ NonCanonicalMonad _ -> doc_monad
+
+ doc_monoid =
+ "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
+ doc_monad =
+ "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -116,6 +116,9 @@ module GHC.Tc.Errors.Types (
, UnusedImportName (..)
, NestedForallsContextsIn(..)
, UnusedNameProv(..)
+ , NonCanonicalDefinition(..)
+ , NonCanonical_Monoid(..)
+ , NonCanonical_Monad(..)
) where
import GHC.Prelude
@@ -4037,6 +4040,19 @@ data TcRnMessage where
-- ^ The locations of the duplicates
-> TcRnMessage
+ {-| TcRnNonCanonicalDefinition is a warning indicating that an instance
+ defines an implementation for a method that should not be defined in a way
+ that deviates from its default implementation, for example because it has
+ been scheduled to be absorbed into another method, like @pure@ making
+ @return@ obsolete.
+
+ Test cases:
+ WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff
+ -}
+ TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics
+ -> !(LHsSigType GhcRn) -- ^ The instance type
+ -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -5567,3 +5583,34 @@ data UnusedNameProv
| UnusedNameTypePattern
| UnusedNameMatch
| UnusedNameLocalBind
+
+-- | Different reasons for TcRnNonCanonicalDefinition.
+data NonCanonicalDefinition =
+ -- | Related to @(<>)@ and @mappend at .
+ NonCanonicalMonoid NonCanonical_Monoid
+ |
+ -- | Related to @(*>)@/@(>>)@ and @pure@/@return at .
+ NonCanonicalMonad NonCanonical_Monad
+ deriving (Generic)
+
+-- | Possible cases for the -Wnoncanonical-monoid-instances.
+data NonCanonical_Monoid =
+ -- | @(<>) = mappend@ was defined.
+ NonCanonical_Sappend
+ |
+ -- | @mappend@ was defined as something other than @(<>)@.
+ NonCanonical_Mappend
+
+-- | Possible cases for the -Wnoncanonical-monad-instances.
+data NonCanonical_Monad =
+ -- | @pure = return@ was defined.
+ NonCanonical_Pure
+ |
+ -- | @(*>) = (>>)@ was defined.
+ NonCanonical_ThenA
+ |
+ -- | @return@ was defined as something other than @pure at .
+ NonCanonical_Return
+ |
+ -- | @(>>)@ was defined as something other than @(*>)@.
+ NonCanonical_ThenM
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -598,6 +598,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIllegalInferredTyVars" = 54832
GhcDiagnosticCode "TcRnAmbiguousName" = 87543
GhcDiagnosticCode "TcRnBindingNameConflict" = 10498
+ GhcDiagnosticCode "NonCanonicalMonoid" = 50928
+ GhcDiagnosticCode "NonCanonicalMonad" = 22705
-- PatSynInvalidRhsReason
GhcDiagnosticCode "PatSynNotInvertible" = 69317
@@ -856,6 +858,7 @@ type family ConRecursInto con where
ConRecursInto "DodgyImportsHiding" = 'Just ImportLookupReason
ConRecursInto "TcRnImportLookup" = 'Just ImportLookupReason
ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason
+ ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition
--
-- TH errors
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -438,6 +438,21 @@ data GhcHint
bind anything useful.
-}
| SuggestRemoveRecordWildcard
+ {-| Suggest moving a method implementation to a different instance to its
+ superclass that defines the canonical version of the method.
+ -}
+ | SuggestMoveNonCanonicalDefinition
+ Name -- ^ move the implementation from this method
+ Name -- ^ ... to this method
+ String -- ^ Documentation URL
+
+ {-| Suggest removing a method implementation when a superclass defines the
+ canonical version of that method.
+ -}
+ | SuggestRemoveNonCanonicalDefinition
+ Name -- ^ method with non-canonical implementation
+ Name -- ^ possible other method to use as the RHS instead
+ String -- ^ Documentation URL
-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -234,6 +234,17 @@ instance Outputable GhcHint where
-> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe."
SuggestRemoveRecordWildcard
-> text "Omit the" <+> quotes (text "..")
+ SuggestMoveNonCanonicalDefinition lhs rhs refURL ->
+ text "Move definition from" <+>
+ quotes (pprPrefixUnqual rhs) <+>
+ text "to" <+> quotes (pprPrefixUnqual lhs) $$
+ text "See also:" <+> text refURL
+ SuggestRemoveNonCanonicalDefinition lhs rhs refURL ->
+ text "Either remove definition for" <+>
+ quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+>
+ text "or define as" <+>
+ quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$
+ text "See also:" <+> text refURL
perhapsAsPat :: SDoc
perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
@@ -343,3 +354,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
pp_ns rdr | ns /= tried_ns = pprNameSpace ns
| otherwise = empty
where ns = rdrNameSpace rdr
+
+pprPrefixUnqual :: Name -> SDoc
+pprPrefixUnqual name =
+ pprPrefixOcc (getOccName name)
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -163,6 +163,7 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Wsemigroup`
* :ghc-flag:`-Wnoncanonical-monoid-instances`
+ * :ghc-flag:`-Wnoncanonical-monad-instances`
* :ghc-flag:`-Wcompat-unqualified-imports`
* :ghc-flag:`-Wtype-equality-out-of-scope`
@@ -566,7 +567,7 @@ of ``-W(no-)*``.
:since: 8.0
- :default: off
+ :default: on
Warn if noncanonical ``Applicative`` or ``Monad`` instances
declarations are detected.
@@ -584,6 +585,8 @@ of ``-W(no-)*``.
* Warn if ``pure`` is defined backwards (i.e. ``pure = return``).
* Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``).
+ This warning is part of the :ghc-flag:`-Wcompat` option group.
+
.. ghc-flag:: -Wnoncanonical-monadfail-instances
:shortdesc: *(deprecated)*
warn when ``Monad`` or ``MonadFail`` instances have
@@ -610,6 +613,8 @@ of ``-W(no-)*``.
:since: 8.0
+ :default: on
+
Warn if noncanonical ``Semigroup`` or ``Monoid`` instances
declarations are detected.
@@ -625,8 +630,7 @@ of ``-W(no-)*``.
* Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``).
- This warning is off by default. However, it is part of the
- :ghc-flag:`-Wcompat` option group.
+ This warning is part of the :ghc-flag:`-Wcompat` option group.
.. ghc-flag:: -Wmissing-monadfail-instances
:shortdesc: *(deprecated)*
=====================================
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
=====================================
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
=====================================
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:
=====================================
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
=====================================
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
=====================================
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
{
=====================================
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
=====================================
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) =
=====================================
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
=====================================
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 =
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/994bda563604461ffb8454d6e298b0310520bcc8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/994bda563604461ffb8454d6e298b0310520bcc8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230505/a440d1a7/attachment-0001.html>
More information about the ghc-commits
mailing list