{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where import GHC.Core.Predicate (isEvVar) import GHC.Core.Type import GHC.Driver.Flags import GHC.Hs import GHC.HsToCore.Errors.Types import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt import GHC.HsToCore.Pmc.Ppr instance Diagnostic DsMessage where type DiagnosticOpts DsMessage = NoDiagnosticOpts defaultDiagnosticOpts = NoDiagnosticOpts diagnosticMessage _ = \case DsUnknownMessage (UnknownDiagnostic @e m) -> diagnosticMessage (defaultDiagnosticOpts @e) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" DsIdentitiesFound conv_fn type_of_conv -> mkSimpleDecorated $ vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv , nest 2 $ text "can probably be omitted" ] DsOverflowedLiterals i tc bounds _possiblyUsingNegativeLiterals -> let msg = case bounds of Nothing -> vcat [ text "Literal" <+> integer i <+> text "is negative but" <+> ppr tc <+> text "only supports positive numbers" ] Just (MinBound minB, MaxBound maxB) -> vcat [ text "Literal" <+> integer i <+> text "is out of the" <+> ppr tc <+> text "range" <+> integer minB <> text ".." <> integer maxB ] in mkSimpleDecorated msg DsRedundantBangPatterns ctx q -> mkSimpleDecorated $ pprEqn ctx q "has redundant bang" DsOverlappingPatterns ctx q -> mkSimpleDecorated $ pprEqn ctx q "is redundant" DsInaccessibleRhs ctx q -> mkSimpleDecorated $ pprEqn ctx q "has inaccessible right hand side" DsMaxPmCheckModelsReached limit -> mkSimpleDecorated $ vcat [ hang (text "Pattern match checker ran into -fmax-pmcheck-models=" <> int limit <> text " limit, so") 2 ( bullet <+> text "Redundant clauses might not be reported at all" $$ bullet <+> text "Redundant clauses might be reported as inaccessible" $$ bullet <+> text "Patterns reported as unmatched might actually be matched") ] DsNonExhaustivePatterns kind _flag maxPatterns vars nablas -> mkSimpleDecorated $ pprContext False kind (text "are non-exhaustive") $ \_ -> case vars of -- See #11245 [] -> text "Guards do not cover entire pattern space" _ -> let us = map (\nabla -> pprUncovered nabla vars) nablas pp_tys = pprQuotedList $ map idType vars in hang (text "Patterns of type" <+> pp_tys <+> text "not matched:") 4 (vcat (take maxPatterns us) $$ dots maxPatterns us) DsTopLevelBindsNotAllowed bindsType bind -> let desc = case bindsType of UnliftedTypeBinds -> "bindings for unlifted types" StrictBinds -> "strict bindings" in mkSimpleDecorated $ hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind) DsUselessSpecialiseForClassMethodSelector poly_id -> mkSimpleDecorated $ text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id) DsUselessSpecialiseForNoInlineFunction poly_id -> mkSimpleDecorated $ text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) DsMultiplicityCoercionsNotSupported -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities" DsOrphanRule rule -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule DsRuleLhsTooComplicated orig_lhs lhs2 -> mkSimpleDecorated $ hang (text "RULE left-hand side too complicated to desugar") 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 , text "Orig lhs:" <+> ppr orig_lhs]) DsRuleIgnoredDueToConstructor con -> mkSimpleDecorated $ vcat [ text "A constructor," <+> ppr con <> text ", appears as outermost match in RULE lhs." , text "This rule will be ignored." ] DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2 -> mkSimpleDecorated $ vcat (map pp_dead unbound) where pp_dead bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr , text "is not bound in RULE lhs"]) 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs , text "Orig lhs:" <+> ppr orig_lhs , text "optimised lhs:" <+> ppr lhs2 ]) pp_bndr b | isTyVar b = text "type variable" <+> quotes (ppr b) | isEvVar b = text "constraint" <+> quotes (ppr (varType b)) | otherwise = text "variable" <+> quotes (ppr b) DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs -> mkSimpleDecorated $ hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ text "Unlifted variables:") 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) unlifted_bndrs)) DsNotYetHandledByTH reason -> case reason of ThAmbiguousRecordUpdates fld -> mkMsg "Ambiguous record updates" (ppr fld) ThAbstractClosedTypeFamily decl -> mkMsg "abstract closed type family" (ppr decl) ThForeignLabel cls -> mkMsg "Foreign label" (doubleQuotes (ppr cls)) ThForeignExport decl -> mkMsg "Foreign export" (ppr decl) ThMinimalPragmas -> mkMsg "MINIMAL pragmas" empty ThSCCPragmas -> mkMsg "SCC pragmas" empty ThNoUserInline -> mkMsg "NOUSERINLINE" empty ThExoticFormOfType ty -> mkMsg "Exotic form of type" (ppr ty) ThAmbiguousRecordSelectors e -> mkMsg "Ambiguous record selectors" (ppr e) ThMonadComprehensionSyntax e -> mkMsg "monad comprehension and [: :]" (ppr e) ThCostCentres e -> mkMsg "Cost centres" (ppr e) ThExpressionForm e -> mkMsg "Expression form" (ppr e) ThExoticStatement other -> mkMsg "Exotic statement" (ppr other) ThExoticLiteral lit -> mkMsg "Exotic literal" (ppr lit) ThExoticPattern pat -> mkMsg "Exotic pattern" (ppr pat) ThGuardedLambdas m -> mkMsg "Guarded lambdas" (pprMatch m) ThNegativeOverloadedPatterns pat -> mkMsg "Negative overloaded patterns" (ppr pat) ThHaddockDocumentation -> mkMsg "Haddock documentation" empty ThWarningAndDeprecationPragmas decl -> mkMsg "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr decl ThSplicesWithinDeclBrackets -> mkMsg "Splices within declaration brackets" empty ThNonLinearDataCon -> mkMsg "Non-linear fields in data constructors" empty where mkMsg what doc = mkSimpleDecorated $ hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc DsAggregatedViewExpressions views -> mkSimpleDecorated (vcat msgs) where msgs = map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) views DsUnbangedStrictPatterns bind -> mkSimpleDecorated $ hang (text "Pattern bindings containing unlifted types should use" $$ text "an outermost bang pattern:") 2 (ppr bind) DsCannotMixPolyAndUnliftedBindings bind -> mkSimpleDecorated $ hang (text "You can't mix polymorphic and unlifted bindings:") 2 (ppr bind) DsWrongDoBind _rhs elt_ty -> mkSimpleDecorated $ badMonadBind elt_ty DsUnusedDoBind _rhs elt_ty -> mkSimpleDecorated $ badMonadBind elt_ty DsRecBindsNotAllowedForUnliftedTys binds -> mkSimpleDecorated $ hang (text "Recursive bindings for unlifted types aren't allowed:") 2 (vcat (map ppr binds)) DsRuleMightInlineFirst rule_name lhs_id _ -> mkSimpleDecorated $ vcat [ hang (text "Rule" <+> pprRuleName rule_name <+> text "may never fire") 2 (text "because" <+> quotes (ppr lhs_id) <+> text "might inline first") ] DsAnotherRuleMightFireFirst rule_name bad_rule lhs_id -> mkSimpleDecorated $ vcat [ hang (text "Rule" <+> pprRuleName rule_name <+> text "may never fire") 2 (text "because rule" <+> pprRuleName bad_rule <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") ] diagnosticReason = \case DsUnknownMessage m -> diagnosticReason m DsEmptyEnumeration -> WarningWithFlag Opt_WarnEmptyEnumerations DsIdentitiesFound{} -> WarningWithFlag Opt_WarnIdentities DsOverflowedLiterals{} -> WarningWithFlag Opt_WarnOverflowedLiterals DsRedundantBangPatterns{} -> WarningWithFlag Opt_WarnRedundantBangPatterns DsOverlappingPatterns{} -> WarningWithFlag Opt_WarnOverlappingPatterns DsInaccessibleRhs{} -> WarningWithFlag Opt_WarnOverlappingPatterns DsMaxPmCheckModelsReached{} -> WarningWithoutFlag DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _ -> maybe WarningWithoutFlag WarningWithFlag mb_flag DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag DsUselessSpecialiseForNoInlineFunction{} -> WarningWithoutFlag DsMultiplicityCoercionsNotSupported{} -> ErrorWithoutFlag DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans DsRuleLhsTooComplicated{} -> WarningWithoutFlag DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag DsRuleBindersNotBound{} -> WarningWithoutFlag DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag DsNotYetHandledByTH{} -> ErrorWithoutFlag DsAggregatedViewExpressions{} -> WarningWithoutFlag DsUnbangedStrictPatterns{} -> WarningWithFlag Opt_WarnUnbangedStrictPatterns DsCannotMixPolyAndUnliftedBindings{} -> ErrorWithoutFlag DsWrongDoBind{} -> WarningWithFlag Opt_WarnWrongDoBind DsUnusedDoBind{} -> WarningWithFlag Opt_WarnUnusedDoBind DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m DsEmptyEnumeration -> noHints DsIdentitiesFound{} -> noHints DsOverflowedLiterals i _tc bounds usingNegLiterals -> case (bounds, usingNegLiterals) of (Just (MinBound minB, MaxBound _), NotUsingNegLiterals) | minB == -i -- Note [Suggest NegativeLiterals] , i > 0 -> [ suggestExtensionWithInfo (text "If you are trying to write a large negative literal") LangExt.NegativeLiterals ] _ -> noHints DsRedundantBangPatterns{} -> noHints DsOverlappingPatterns{} -> noHints DsInaccessibleRhs{} -> noHints DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels] DsNonExhaustivePatterns{} -> noHints DsTopLevelBindsNotAllowed{} -> noHints DsUselessSpecialiseForClassMethodSelector{} -> noHints DsUselessSpecialiseForNoInlineFunction{} -> noHints DsMultiplicityCoercionsNotSupported -> noHints DsOrphanRule{} -> noHints DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints DsRuleBindersNotBound{} -> noHints DsLazyPatCantBindVarsOfUnliftedType{} -> noHints DsNotYetHandledByTH{} -> noHints DsAggregatedViewExpressions{} -> noHints DsUnbangedStrictPatterns{} -> noHints DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignatures UnnamedBinding] DsWrongDoBind rhs _ -> [SuggestBindToWildcard rhs] DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs] DsRecBindsNotAllowedForUnliftedTys{} -> noHints DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] diagnosticCode = constructorCode {- Note [Suggest NegativeLiterals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you write x :: Int8 x = -128 it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. We get an erroneous suggestion for x = 128 but perhaps that does not matter too much. -} -- -- Helper functions -- badMonadBind :: Type -> SDoc badMonadBind elt_ty = hang (text "A do-notation statement discarded a result of type") 2 (quotes (ppr elt_ty)) -- Print a single clause (for redundant/with-inaccessible-rhs) pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc pprEqn ctx q txt = pprContext True ctx (text txt) $ \f -> f (q <+> matchSeparator ctx <+> text "...") pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pprContext singular kind msg rest_of_msg_fun = vcat [text txt <+> msg, sep [ text "In" <+> ppr_match <> char ':' , nest 4 (rest_of_msg_fun pref)]] where txt | singular = "Pattern match" | otherwise = "Pattern match(es)" (ppr_match, pref) = case kind of FunRhs { mc_fun = L _ fun } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) dots :: Int -> [a] -> SDoc dots maxPatterns qs | qs `lengthExceeds` maxPatterns = text "..." | otherwise = empty