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 +++++++ 7 files changed, 181 insertions(+), 62 deletions(-) (limited to 'compiler') 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) -- cgit v1.2.1