From 994bda563604461ffb8454d6e298b0310520bcc8 Mon Sep 17 00:00:00 2001 From: Torsten Schmits 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. --- compiler/GHC/Driver/Flags.hs | 1 + compiler/GHC/Rename/Module.hs | 77 ++++---------------- compiler/GHC/Tc/Errors/Ppr.hs | 85 ++++++++++++++++++++++ compiler/GHC/Tc/Errors/Types.hs | 47 ++++++++++++ compiler/GHC/Types/Error/Codes.hs | 3 + compiler/GHC/Types/Hint.hs | 15 ++++ compiler/GHC/Types/Hint/Ppr.hs | 15 ++++ docs/users_guide/using-warnings.rst | 10 ++- 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 +++++++++-- 23 files changed, 282 insertions(+), 129 deletions(-) diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index df49034d13..3496b2af5a 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -929,6 +929,7 @@ minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports , Opt_WarnTypeEqualityOutOfScope ] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index e91749cf2d..319dececdd 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/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 diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 751a5f7682..269063ae65 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/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" diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 23dc2cd3b0..68c5ca2869 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/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@. + NonCanonicalMonoid NonCanonical_Monoid + | + -- | Related to @(*>)@/@(>>)@ and @pure@/@return@. + 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@. + NonCanonical_Return + | + -- | @(>>)@ was defined as something other than @(*>)@. + NonCanonical_ThenM diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index cb80f713d4..33cdd696f3 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/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 diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 773ed4941d..7057925dea 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/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 diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index 76e678bb36..4454d872cd 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/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) diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 62a0f723df..577bce0a74 100644 --- a/docs/users_guide/using-warnings.rst +++ b/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)* 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