diff options
40 files changed, 1016 insertions, 469 deletions
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 409d0ff6d3..e61be3dd69 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -431,7 +431,7 @@ dsRule (L loc (HsRule { rd_name = name -- and take the body apart into a (f args) form ; dflags <- getDynFlags ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; + Left msg -> do { diagnosticDs msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do { let is_local = isLocalId fn_id @@ -466,26 +466,10 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries , idInlineActivation lhs_id `competesWith` rule_act - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - + = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) - + = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id) | otherwise = return () diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 9183a4f8ed..cad3e82154 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -33,6 +33,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalB import GHC.Tc.Utils.TcType import GHC.Core.Type( splitPiTy ) import GHC.Core.Multiplicity +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs @@ -40,6 +41,7 @@ import GHC.Core.Utils import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) + import GHC.Types.Id import GHC.Core.ConLike import GHC.Builtin.Types @@ -121,8 +123,7 @@ mkCmdEnv tc_meths -> Maybe Id -> DsM () check_lev_poly _ Nothing = return () check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) - (text "In the result of the function" <+> quotes (ppr id)) + = dsNoLevPoly (nTimes arity res_type (idType id)) (LevityCheckMkCmdEnv id) -- arr :: forall b c. (b -> c) -> a b c @@ -631,8 +632,7 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) env_ids = do putSrcSpanDsA loc $ - dsNoLevPoly stmts_ty - (text "In the do-command:" <+> ppr do_block) + dsNoLevPoly stmts_ty (LevityCheckDoCmd do_block) (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -702,8 +702,7 @@ dsfixCmd DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty - (text "When desugaring the command:" <+> ppr cmd) + = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty (LevityCheckDesugaringCmd cmd) ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } -- Feed back the list of local variables actually used a command, @@ -792,8 +791,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- ---> premap (\ (xs) -> ((xs), ())) c dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDsA loc $ dsNoLevPoly res_ty - (text "In the command:" <+> ppr body) + putSrcSpanDsA loc $ dsNoLevPoly res_ty (LevityCheckInCmd body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids env_var <- newSysLocalDs Many env_ty @@ -861,7 +859,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here + dsNoLevPoly c_ty LevityCheckCmdStmt snd_fn <- mkSndExpr c_ty out_ty return (do_premap ids in_ty before_c_ty out_ty core_mux $ do_compose ids before_c_ty after_c_ty out_ty diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index db5bb68706..c5a47f388a 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -28,6 +28,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) import GHC.HsToCore.Monad +import GHC.HsToCore.Errors.Types import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) @@ -90,8 +91,8 @@ dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) - = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict bindings") bang_binds + = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds + ; mapBagM_ (top_level_err StrictBinds) bang_binds ; return nilOL } | otherwise @@ -107,10 +108,9 @@ dsTopLHsBinds binds unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (L loc bind) + top_level_err bindsType (L loc bind) = putSrcSpanDs (locA loc) $ - errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") - 2 (ppr bind)) + diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind) -- | Desugar all other kind of bindings, Ids of strict binds are returned to @@ -665,16 +665,14 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ - do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) + do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id) ; return Nothing } -- There is no point in trying to specialise a class op -- Moreover, classops don't (currently) have an inl_sat arity set -- (it would be Just 0) and that in turn makes makeCorePair bleat | no_act_spec && isNeverActive rule_act = putSrcSpanDs loc $ - do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) + do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id) ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] @@ -699,7 +697,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ dflags <- getDynFlags ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { - Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; + Left msg -> do { diagnosticDs msg; return Nothing } ; Right (rule_bndrs, _fn, rule_lhs_args) -> do { this_mod <- getModule @@ -768,12 +766,9 @@ dsMkUserRule :: Module -> Bool -> RuleName -> Activation dsMkUserRule this_mod is_local name act fn bndrs args rhs = do let rule = mkRule this_mod False is_local name act fn bndrs args rhs when (isOrphan (ru_orphan rule)) $ - diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule) + diagnosticDs (DsOrphanRule rule) return rule -ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule - {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to warn that using SPECIALISE for a function marked INLINE @@ -836,7 +831,7 @@ SPEC f :: ty [n] INLINE [k] -} decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr - -> Either SDoc ([Var], Id, [CoreExpr]) + -> Either DsMessage ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs -- may add some extra dictionary binders (see Note [Free dictionaries]) @@ -846,10 +841,10 @@ decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr decomposeRuleLhs dflags orig_bndrs orig_lhs | not (null unbound) -- Check for things unbound on LHS -- See Note [Unused spec binders] - = Left (vcat (map dead_msg unbound)) + = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) | Var funId <- fun2 , Just con <- isDataConId_maybe funId - = Left (constructor_msg con) -- See Note [No RULES on datacons] + = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | Just (fn_id, args) <- decompose fun2 args2 , let extra_bndrs = mk_extra_bndrs fn_id args = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs @@ -861,7 +856,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs Right (orig_bndrs ++ extra_bndrs, fn_id, args) | otherwise - = Left bad_shape_msg + = Left (DsRuleLhsTooComplicated orig_lhs lhs2) where simpl_opts = initSimpleOpts dflags lhs1 = drop_dicts orig_lhs @@ -893,24 +888,6 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs decompose _ _ = Nothing - bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") - 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 - , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg 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 bndr - | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) - | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr)) - | otherwise = text "variable" <+> quotes (ppr bndr) - - constructor_msg con = vcat - [ text "A constructor," <+> ppr con <> - text ", appears as outermost match in RULE lhs." - , text "This rule will be ignored." ] - drop_dicts :: CoreExpr -> CoreExpr drop_dicts e = wrap_lets needed bnds body @@ -1135,7 +1112,7 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc) ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc + ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg (LevityCheckWpFun doc) ; if ok then return (\e -> (Lam x (w2 (app e arg)))) else return id } -- this return is irrelevant @@ -1145,7 +1122,7 @@ dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm ; return (\e -> App e core_tm) } -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ - errDs (text "Multiplicity coercions are currently not supported") + diagnosticDs DsMultiplicityCoercionsNotSupported ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index b8d2a0a86c..87846bb8f2 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -1,11 +1,359 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where -import GHC.Types.Error +import GHC.Builtin.Names (withDictName) +import GHC.Core.Predicate (isEvVar) +import GHC.Core.TyCo.Ppr (pprWithTYPE) +import GHC.Core.Type +import GHC.Core.Utils (exprType) +import GHC.Driver.Flags +import GHC.Hs import GHC.HsToCore.Errors.Types +import GHC.Prelude +import GHC.Tc.Errors.Ppr (formatLevPolyErr, pprLevityPolyInType) +import GHC.Types.Basic (pprRuleName) +import GHC.Types.Error +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 - diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m - diagnosticReason (DsUnknownMessage m) = diagnosticReason m - diagnosticHints (DsUnknownMessage m) = diagnosticHints m + diagnosticMessage = \case + DsUnknownMessage m + -> diagnosticMessage 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 NOINLINE function:" <+> quotes (ppr poly_id) + DsUselessSpecialiseForNoInlineFunction poly_id + -> mkSimpleDecorated $ + text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) + DsMultiplicityCoercionsNotSupported + -> mkSimpleDecorated $ text "Multiplicity coercions are currently not supported" + 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) + DsMultipleConForNewtype names + -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names + 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 + ThDefaultDeclarations decl + -> mkMsg "Default declarations" (ppr decl) + ThSplicesWithinDeclBrackets + -> mkMsg "Splices within declaration brackets" 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) + DsInvalidInstantiationDictAtType wrapped_ty + -> mkSimpleDecorated $ + hang (text "Invalid instantiation of" <+> + quotes (ppr withDictName) <+> text "at type:") + 4 (ppr wrapped_ty) + 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)) + DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys + -> mkSimpleDecorated $ + vcat [ hang (text "Cannot use function with levity-polymorphic arguments:") + 2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty)) + , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat + [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" + , text "are eta-expanded internally because they must occur fully saturated." + , text "Use -fprint-typechecker-elaboration to display the full expression.)" + ] + , hang (text "Levity-polymorphic arguments:") + 2 $ vcat $ map + (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) + bad_tys + ] + 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") + ] + DsLevityPolyInExpr e prov + -> let extra = case prov of + LevityCheckHsExpr hsExpr -> ppr hsExpr + LevityCheckWpFun doc -> doc + LevityCheckInSyntaxExpr (DsArgNum n) expr + -> text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) + + in mkSimpleDecorated $ + formatLevPolyErr (exprType e) $$ (text "In the type of expression:" <+> extra) + DsLevityPolyInType ty prov + -> mkSimpleDecorated $ pprLevityPolyInType ty prov + + 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 + DsMultipleConForNewtype{} -> ErrorWithoutFlag + DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag + DsNotYetHandledByTH{} -> ErrorWithoutFlag + DsAggregatedViewExpressions{} -> WarningWithoutFlag + DsUnbangedStrictPatterns{} -> WarningWithFlag Opt_WarnUnbangedStrictPatterns + DsCannotMixPolyAndUnliftedBindings{} -> ErrorWithoutFlag + DsInvalidInstantiationDictAtType{} -> ErrorWithoutFlag + DsWrongDoBind{} -> WarningWithFlag Opt_WarnWrongDoBind + DsUnusedDoBind{} -> WarningWithFlag Opt_WarnUnusedDoBind + DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag + DsCannotUseFunWithPolyArgs{} -> ErrorWithoutFlag + DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsLevityPolyInExpr{} -> ErrorWithoutFlag + DsLevityPolyInType{} -> ErrorWithoutFlag + + 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 -> [SuggestExtension 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 + DsMultipleConForNewtype{} -> noHints + DsLazyPatCantBindVarsOfUnliftedType{} -> noHints + DsNotYetHandledByTH{} -> noHints + DsAggregatedViewExpressions{} -> noHints + DsUnbangedStrictPatterns{} -> noHints + DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignature] + DsWrongDoBind rhs _ -> [SuggestBindToWildcard rhs] + DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs] + DsRecBindsNotAllowedForUnliftedTys{} -> noHints + DsInvalidInstantiationDictAtType{} -> noHints + DsCannotUseFunWithPolyArgs{} -> noHints + DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] + DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + DsLevityPolyInExpr{} -> noHints + DsLevityPolyInType{} -> noHints + +{- +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 diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 45a47d5c30..950d4aa42a 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -1,10 +1,209 @@ +{-# LANGUAGE ExistentialQuantification #-} module GHC.HsToCore.Errors.Types where +import Data.Typeable + +import GHC.Prelude + +import GHC.Core (CoreRule, CoreExpr, RuleName) +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Driver.Session +import GHC.Hs +import GHC.HsToCore.Pmc.Solver.Types +import GHC.Tc.Errors.Types (LevityCheckProvenance) +import GHC.Types.Basic (Activation) import GHC.Types.Error +import GHC.Types.ForeignCall +import GHC.Types.Id +import GHC.Types.Name (Name) +import GHC.Utils.Outputable +import qualified GHC.LanguageExtensions as LangExt + +newtype MinBound = MinBound Integer +newtype MaxBound = MaxBound Integer +type MaxUncoveredPatterns = Int +type MaxPmCheckModels = Int -- | Diagnostics messages emitted during desugaring. -data DsMessage = - DsUnknownMessage !DiagnosticMessage - -- ^ Simply rewraps a generic 'DiagnosticMessage'. More - -- constructors will be added in the future (#18516). +data DsMessage + -- | Simply wraps a generic 'Diagnostic' message. + = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a + + {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is + emitted if an enumeration is empty. + + Example(s): + + main :: IO () + main = do + let enum = [5 .. 3] + print enum + + Here 'enum' would yield an empty list, because 5 is greater than 3. + + Test case(s): + warnings/should_compile/T10930 + warnings/should_compile/T18402 + warnings/should_compile/T10930b + numeric/should_compile/T10929 + numeric/should_compile/T7881 + deSugar/should_run/T18172 + + -} + | DsEmptyEnumeration + + {-| DsIdentitiesFound is a warning (controlled by the -Widentities flag) that is + emitted on uses of Prelude numeric conversions that are probably the identity + (and hence could be omitted). + + Example(s): + + main :: IO () + main = do + let x = 10 + print $ conv 10 + + where + conv :: Int -> Int + conv x = fromIntegral x + + Here calling 'conv' is essentially the identity function, and therefore can be omitted. + + Test case(s): + deSugar/should_compile/T4488 + -} + | DsIdentitiesFound !Id -- The conversion function + !Type -- The type of conversion + + | DsOverflowedLiterals !Integer + !Name + !(Maybe (MinBound, MaxBound)) + !NegLiteralExtEnabled + + -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately + -- 'SrcInfo' gives us an 'SDoc' to begin with. + | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc + + -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately + -- 'SrcInfo' gives us an 'SDoc' to begin with. + | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc + + -- FIXME(adn) Use a proper type instead of 'SDoc' + | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc + + | DsMaxPmCheckModelsReached !MaxPmCheckModels + + | DsNonExhaustivePatterns !(HsMatchContext GhcRn) + !ExhaustivityCheckType + !MaxUncoveredPatterns + [Id] + [Nabla] + + | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc) + + | DsUselessSpecialiseForClassMethodSelector !Id + + | DsUselessSpecialiseForNoInlineFunction !Id + + | DsMultiplicityCoercionsNotSupported + + | DsOrphanRule !CoreRule + + | DsRuleLhsTooComplicated !CoreExpr !CoreExpr + + | DsRuleIgnoredDueToConstructor !DataCon + + | DsRuleBindersNotBound ![Var] + -- ^ The list of unbound binders + ![Var] + -- ^ The original binders + !CoreExpr + -- ^ The original LHS + !CoreExpr + -- ^ The optimised LHS + + | DsMultipleConForNewtype [LocatedN Name] + + | DsLazyPatCantBindVarsOfUnliftedType [Var] + + | DsNotYetHandledByTH !ThRejectionReason + + | DsAggregatedViewExpressions [[LHsExpr GhcTc]] + + | DsUnbangedStrictPatterns !(HsBindLR GhcTc GhcTc) + + | DsCannotMixPolyAndUnliftedBindings !(HsBindLR GhcTc GhcTc) + + | DsInvalidInstantiationDictAtType !Type + + | DsWrongDoBind !(LHsExpr GhcTc) !Type + + | DsUnusedDoBind !(LHsExpr GhcTc) !Type + + | DsRecBindsNotAllowedForUnliftedTys ![LHsBindLR GhcTc GhcTc] + + -- NOTE(adn) The first argument is an opaque 'expr' with an + -- 'Outputable' constraint because this messages is emitted from + -- 'GHC.HsToCore.Expr.checkLevPolyArgs' which gets passed a polymorphic + -- 'Outputable' type. + | forall expr. Outputable expr => DsCannotUseFunWithPolyArgs !expr !Type ![Type] + + | DsRuleMightInlineFirst !RuleName !Var !Activation + + | DsAnotherRuleMightFireFirst !RuleName + !RuleName -- the \"bad\" rule + !Var + + | DsLevityPolyInExpr !CoreExpr !LevityExprProvenance + + | DsLevityPolyInType !Type !LevityCheckProvenance + +-- The positional number of the argument for an expression (first, second, third, etc) +newtype DsArgNum = DsArgNum Int + +-- | Where the levity checking for the expression originated +data LevityExprProvenance + = LevityCheckHsExpr !(HsExpr GhcTc) + | LevityCheckWpFun !SDoc -- FIXME(adn) Alas 'WpFun' gives us an SDoc here. + | LevityCheckInSyntaxExpr !DsArgNum !(HsExpr GhcTc) + +-- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' +-- constructor of a 'DsMessage'. +data ThRejectionReason + = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn) + | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn) + | ThForeignLabel !CLabelString + | ThForeignExport !(LForeignDecl GhcRn) + | ThMinimalPragmas + | ThSCCPragmas + | ThNoUserInline + | ThExoticFormOfType !(HsType GhcRn) + | ThAmbiguousRecordSelectors !(HsExpr GhcRn) + | ThMonadComprehensionSyntax !(HsExpr GhcRn) + | ThCostCentres !(HsExpr GhcRn) + | ThExpressionForm !(HsExpr GhcRn) + | ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)] + | ThExoticLiteral !(HsLit GhcRn) + | ThExoticPattern !(Pat GhcRn) + | ThGuardedLambdas !(Match GhcRn (LHsExpr GhcRn)) + | ThNegativeOverloadedPatterns !(Pat GhcRn) + | ThHaddockDocumentation + | ThWarningAndDeprecationPragmas [LIdP GhcRn] + | ThDefaultDeclarations !(DefaultDecl GhcRn) + | ThSplicesWithinDeclBrackets + +data NegLiteralExtEnabled + = YesUsingNegLiterals + | NotUsingNegLiterals + +negLiteralExtEnabled :: DynFlags -> NegLiteralExtEnabled +negLiteralExtEnabled dflags = + if (xopt LangExt.NegativeLiterals dflags) then YesUsingNegLiterals else NotUsingNegLiterals + +newtype ExhaustivityCheckType = ExhaustivityCheckType (Maybe WarningFlag) + +data BindsType + = UnliftedTypeBinds + | StrictBinds diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 0735ed9000..bd84e21ace 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -29,6 +29,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env @@ -57,7 +58,6 @@ import GHC.Types.Var.Env import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.TyCo.Ppr( pprWithTYPE ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic @@ -125,7 +125,7 @@ ds_val_bind (NonRecursive, hsbinds) body = putSrcSpanDs (locA loc) $ -- see Note [Strict binds checks] in GHC.HsToCore.Binds if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) + then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind) -- data Ptr a = Ptr Addr# -- f x = let p@(Ptr y) = ... in ... -- Here the binding for 'p' is polymorphic, but does @@ -133,7 +133,7 @@ ds_val_bind (NonRecursive, hsbinds) body -- use a bang pattern. #6078. else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + diagnosticDs (DsUnbangedStrictPatterns bind) -- Complain about a binding that looks lazy -- e.g. let I# y = x in ... -- Remember, in checkStrictBinds we are going to do strict @@ -148,22 +148,11 @@ ds_val_bind (NonRecursive, hsbinds) body = not (null tvs && null evs) is_polymorphic _ = False - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" ds_val_bind (is_rec, binds) _body | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds = assert (isRec is_rec ) - errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) + errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds) -- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body @@ -261,7 +250,7 @@ dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) = putSrcSpanDsA loc $ do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; dsNoLevPolyExpr e' (LevityCheckHsExpr e) ; return e' } dsExpr :: HsExpr GhcTc -> DsM CoreExpr @@ -809,10 +798,10 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr = expr ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) + ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ]) (\_ -> core_res_wrap (mkApps fun wrapped_args)) } where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) + mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] @@ -1101,8 +1090,7 @@ warnDiscardedDoBindings rhs rhs_ty -- Warn about discarding non-() things in 'monadic' binding ; if warn_unused && not (isUnitTy norm_elt_ty) - then diagnosticDs (WarningWithFlag Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) + then diagnosticDs (DsUnusedDoBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, @@ -1111,21 +1099,12 @@ warnDiscardedDoBindings rhs rhs_ty case tcSplitAppTy_maybe norm_elt_ty of Just (elt_m_ty, _) | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> diagnosticDs (WarningWithFlag Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) + -> diagnosticDs (DsWrongDoBind rhs elt_ty) _ -> return () } } | otherwise -- RHS does have type of form (m ty), which is weird = return () -- but at least this warning is irrelevant -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc -badMonadBind rhs elt_ty - = vcat [ hang (text "A do-notation statement discarded a result of type") - 2 (quotes (ppr elt_ty)) - , hang (text "Suppress this warning by saying") - 2 (quotes $ text "_ <-" <+> ppr rhs) - ] - {- ************************************************************************ * * @@ -1322,9 +1301,7 @@ ds_withDict wrapped_ty ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) } | otherwise - = errDsCoreExpr $ hang (text "Invalid instantiation of" <+> - quotes (ppr withDictName) <+> text "at type:") - 4 (ppr wrapped_ty) + = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty) {- Note [withDict] ~~~~~~~~~~~~~~~~~~ @@ -1478,18 +1455,5 @@ checkLevPolyArgs orig_hs_expr ty arg_tys = mapMaybe binderRelevantType_maybe binders bad_tys = filter isTypeLevPoly arg_tys , not (null bad_tys) - = errDs $ vcat - [ hang (text "Cannot use function with levity-polymorphic arguments:") - 2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty)) - , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat - [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" - , text "are eta-expanded internally because they must occur fully saturated." - , text "Use -fprint-typechecker-elaboration to display the full expression.)" - ] - , hang (text "Levity-polymorphic arguments:") - 2 $ vcat $ map - (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) - bad_tys - ] - + = diagnosticDs $ DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys | otherwise = return () diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index fb338208fc..0816bf3c1c 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -16,6 +16,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import GHC.Hs +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Utils.Zonk import GHC.Core import GHC.Core.Make @@ -138,8 +139,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM , Var unzip_fn' , inner_list_expr' ] - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) - (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) (LevityCheckInFunUse using) -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 33ffc1e998..50aaef9b56 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -46,6 +46,7 @@ import GHC.Types.Id import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal import GHC.Core.Type @@ -247,10 +248,9 @@ match (v:vs) ty eqns -- Eqns *can* be empty case p of PgView e _ -> e:acc _ -> acc) [] group) eqns maybeWarn [] = return () - maybeWarn l = diagnosticDs WarningWithoutFlag (vcat l) + maybeWarn l = diagnosticDs (DsAggregatedViewExpressions l) in - maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) - (filter (not . null) gs)) + maybeWarn $ filter (not . null) gs matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) -- See Note [Empty case expressions] @@ -455,10 +455,7 @@ tidy1 v _ (LazyPat _ pat) = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) ; unless (null unlifted_bndrs) $ putSrcSpanDs (getLocA pat) $ - errDs (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))) + diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index b2f7043f45..d8da036dba 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -30,6 +30,7 @@ import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Monad import GHC.HsToCore.Utils @@ -56,7 +57,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString -import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) import Control.Monad @@ -263,10 +263,7 @@ warnAboutIdentities dflags conv_fn type_of_conv , idName conv_fn `elem` conversionNames , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = diagnosticDs (WarningWithFlag Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) + = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) warnAboutIdentities _ _ _ = return () conversionNames :: [Name] @@ -347,37 +344,13 @@ warnAboutOverflowedLiterals dflags lit checkPositive :: Integer -> Name -> DsM () checkPositive i tc = when (i < 0) $ - diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is negative but" <+> ppr tc - <+> text "only supports positive numbers" - ]) + diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags)) check i tc minB maxB = when (i < minB || i > maxB) $ - diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> text "range" - <+> integer minB <> text ".." <> integer maxB - , sug ]) + diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags)) where - sug | minB == -i -- Note [Suggest NegativeLiterals] - , i > 0 - , not (xopt LangExt.NegativeLiterals dflags) - = text "If you are trying to write a large negative literal, use NegativeLiterals" - | otherwise = Outputable.empty - -{- -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. --} + bounds = Just (MinBound minB, MaxBound maxB) warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) @@ -441,7 +414,7 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr | otherwise = return () where raiseWarning = - diagnosticDs (WarningWithFlag Opt_WarnEmptyEnumerations) (text "Enumeration is empty") + diagnosticDs DsEmptyEnumeration getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 6844606276..91cb41c46c 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -40,7 +40,7 @@ module GHC.HsToCore.Monad ( dsGetCompleteMatches, -- Warnings and errors - DsWarning, diagnosticDs, warnIfSetDs, errDs, errDsCoreExpr, + DsWarning, diagnosticDs, errDsCoreExpr, failWithDs, failDs, discardWarningsDs, askNoErrsDs, @@ -79,8 +79,9 @@ import GHC.Core.Multiplicity import GHC.IfaceToCore +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) +import GHC.Tc.Utils.TcMType ( checkForLevPolyX ) import GHC.Builtin.Names @@ -431,9 +432,8 @@ newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t) newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) mk_local :: FastString -> Mult -> Type -> DsM Id -mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context +mk_local fs w ty = do { dsNoLevPoly ty LevityCheckInVarType -- could improve the msg with another + -- parameter indicating context ; mkSysLocalOrCoVarM fs w ty } {- @@ -466,43 +466,27 @@ putSrcSpanDs (RealSrcSpan real_span _) thing_inside putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) --- | Emit a diagnostic for the current source location --- NB: Warns whether or not -Wxyz is set -diagnosticDs :: DiagnosticReason -> SDoc -> DsM () -diagnosticDs reason warn +-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning, +-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags. +-- See Note [Discarding Messages] in 'GHC.Types.Error'. +diagnosticDs :: DsMessage -> DsM () +diagnosticDs dsMessage = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags - ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $ - DsUnknownMessage $ - mkPlainDiagnostic reason noHints warn + ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) dsMessage ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } --- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags -warnIfSetDs :: WarningFlag -> SDoc -> DsM () -warnIfSetDs flag warn - = whenWOptM flag $ - diagnosticDs (WarningWithFlag flag) warn - -errDs :: SDoc -> DsM () -errDs err - = do { env <- getGblEnv - ; loc <- getSrcSpanDs - ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $ - DsUnknownMessage $ - mkPlainError noHints err - ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } - -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors. -errDsCoreExpr :: SDoc -> DsM CoreExpr -errDsCoreExpr err - = do { errDs err +errDsCoreExpr :: DsMessage -> DsM CoreExpr +errDsCoreExpr msg + = do { diagnosticDs msg ; return unitExpr } -failWithDs :: SDoc -> DsM a -failWithDs err - = do { errDs err +failWithDs :: DsMessage -> DsM a +failWithDs msg + = do { diagnosticDs msg ; failM } failDs :: DsM a @@ -604,16 +588,17 @@ discardWarningsDs thing_inside ; return result } -- | Fail with an error message if the type is levity polymorphic. -dsNoLevPoly :: Type -> SDoc -> DsM () +dsNoLevPoly :: Type -> LevityCheckProvenance -> DsM () -- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty +dsNoLevPoly ty provenance = + checkForLevPolyX (\ty -> failWithDs . DsLevityPolyInType ty) provenance ty -- | Check an expression for levity polymorphism, failing if it is -- levity polymorphic. -dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () +dsNoLevPolyExpr :: CoreExpr -> LevityExprProvenance -> DsM () -- See Note [Levity polymorphism checking] -dsNoLevPolyExpr e doc - | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) +dsNoLevPolyExpr e provenance + | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance) | otherwise = return () -- | Runs the thing_inside. If there are no errors, then returns the expr diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index a9e97ef781..a05e3597be 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -43,12 +43,12 @@ module GHC.HsToCore.Pmc ( import GHC.Prelude +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Desugar import GHC.HsToCore.Pmc.Check import GHC.HsToCore.Pmc.Solver -import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session @@ -330,7 +330,7 @@ formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do -- | Issue all the warnings -- (redundancy, inaccessibility, exhaustiveness, redundant bangs). reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM () -reportWarnings dflags ctx@(DsMatchContext kind loc) vars +reportWarnings dflags (DsMatchContext kind loc) vars CheckResult { cr_ret = CIRB { cirb_inacc = inaccessible_rhss , cirb_red = redundant_rhss , cirb_bangs = redundant_bangs } @@ -345,55 +345,26 @@ reportWarnings dflags ctx@(DsMatchContext kind loc) vars approx = precision == Approximate when (approx && (exists_u || exists_i)) $ - putSrcSpanDs loc (diagnosticDs WarningWithoutFlag approx_msg) + putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags))) when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnRedundantBangPatterns) - (pprEqn q "has redundant bang")) + putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q)) when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) - (pprEqn q "is redundant")) + putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q)) when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) - (pprEqn q "has inaccessible right hand side")) + putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q)) - when exists_u $ putSrcSpanDs loc $ diagnosticDs flag_u_reason $ - pprEqns vars unc_examples + when exists_u $ + putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples)) where flag_i = overlapping dflags kind flag_u = exhaustive dflags kind flag_b = redundantBang dflags - flag_u_reason = maybe WarningWithoutFlag WarningWithFlag (exhaustiveWarningFlag kind) + check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind) maxPatterns = maxUncoveredPatterns dflags - -- Print a single clause (for redundant/with-inaccessible-rhs) - pprEqn q txt = pprContext True ctx (text txt) $ \f -> - f (q <+> matchSeparator kind <+> text "...") - - -- Print several clauses (for uncovered clauses) - pprEqns vars nablas = pprContext False ctx (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) - - approx_msg = vcat - [ hang - (text "Pattern match checker ran into -fmax-pmcheck-models=" - <> int (maxPmCheckModels dflags) - <> 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") - , text "Increase the limit or resolve the warnings to suppress this message." ] - getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla] getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas) where @@ -404,26 +375,6 @@ getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas) back <- go (n - length front) nablas pure (front ++ back) -dots :: Int -> [a] -> SDoc -dots maxPatterns qs - | qs `lengthExceeds` maxPatterns = text "..." - | otherwise = empty - -pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc -pprContext singular (DsMatchContext kind _loc) 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) - -- -- * Adding external long-distance information -- diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs index eddab8df6e..e8221d961f 100644 --- a/compiler/GHC/HsToCore/Pmc/Ppr.hs +++ b/compiler/GHC/HsToCore/Pmc/Ppr.hs @@ -5,7 +5,7 @@ -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.Pmc.Ppr ( - pprUncovered + pprUncovered ) where import GHC.Prelude @@ -25,7 +25,6 @@ import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import GHC.HsToCore.Pmc.Types -import GHC.HsToCore.Pmc.Solver -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- components and refutable shapes associated to any mentioned variables. diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 65bf188bf4..6efd44a5aa 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -23,7 +23,6 @@ Authors: George Karachalias <george.karachalias@cs.kuleuven.be> module GHC.HsToCore.Pmc.Solver ( Nabla, Nablas(..), initNablas, - lookupRefuts, lookupSolution, PhiCt(..), PhiCts, addPhiCtNablas, @@ -510,58 +509,9 @@ inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive. In order to avoid this pitfall, we need to normalise the type passed to pmTopNormaliseType, using the constraint solver to solve for any local equalities (such as i ~ Int) that may be in scope. --} ------------------------ --- * Looking up VarInfo - -emptyRCM :: ResidualCompleteMatches -emptyRCM = RCM Nothing Nothing - -emptyVarInfo :: Id -> VarInfo -emptyVarInfo x - = VI - { vi_id = x - , vi_pos = [] - , vi_neg = emptyPmAltConSet - -- Case (3) in Note [Strict fields and fields of unlifted type] - , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot - , vi_rcm = emptyRCM - } - -lookupVarInfo :: TmState -> Id -> VarInfo --- (lookupVarInfo tms x) tells what we know about 'x' -lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x) - --- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks --- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the --- returned @y@ doesn't have a positive newtype constructor constraint --- associated with it (yet). The 'VarInfo' returned is that of @y@'s --- representative. --- --- Careful, this means that @idType x@ might be different to @idType y@, even --- modulo type normalisation! --- --- See also Note [Coverage checking Newtype matches]. -lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo) -lookupVarInfoNT ts x = case lookupVarInfo ts x of - VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y - res -> (x, res) - where - as_newtype = listToMaybe . mapMaybe go - go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]} - | isNewDataCon dc = Just y - go _ = Nothing - -trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla) -trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x - = set_vi <$> f (lookupVarInfo ts x) - where - set_vi (a, vi') = - (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } }) - -{- Note [Coverage checking Newtype matches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Coverage checking Newtype matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation testing purposes (e.g. at construction sites), they behave rather like a DataCon @@ -588,28 +538,6 @@ Handling of Newtypes is also described in the Appendix of the Lower Your Guards where you can find the solution in a perhaps more digestible format. -} ------------------------------------------------- --- * Exported utility functions querying 'Nabla' - -lookupRefuts :: Nabla -> Id -> [PmAltCon] --- Unfortunately we need the extra bit of polymorphism and the unfortunate --- duplication of lookupVarInfo here. -lookupRefuts MkNabla{ nabla_tm_st = ts } x = - pmAltConSetElems $ vi_neg $ lookupVarInfo ts x - -isDataConSolution :: PmAltConApp -> Bool -isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True -isDataConSolution _ = False - --- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from --- possibly many, preferring 'RealDataCon' solutions whenever possible. -lookupSolution :: Nabla -> Id -> Maybe PmAltConApp -lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of - [] -> Nothing - pos - | Just sol <- find isDataConSolution pos -> Just sol - | otherwise -> Just (head pos) - ------------------------- -- * Adding φ constraints -- diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs index 9cec967592..a111bbdd33 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} - {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement @@ -11,6 +11,10 @@ module GHC.HsToCore.Pmc.Solver.Types ( -- * Normalised refinement types BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..), Nabla(..), Nablas(..), initNablas, + lookupRefuts, lookupSolution, + + -- ** Looking up 'VarInfo' + lookupVarInfo, lookupVarInfoNT, trvVarInfo, -- ** Caching residual COMPLETE sets CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, @@ -273,6 +277,77 @@ instance Outputable ResidualCompleteMatches where -- formats as "[{Nothing,Just},{P,Q}]" ppr rcm = ppr (getRcm rcm) +----------------------- +-- * Looking up VarInfo + +emptyRCM :: ResidualCompleteMatches +emptyRCM = RCM Nothing Nothing + +emptyVarInfo :: Id -> VarInfo +emptyVarInfo x + = VI + { vi_id = x + , vi_pos = [] + , vi_neg = emptyPmAltConSet + -- Case (3) in Note [Strict fields and fields of unlifted type] + -- in GHC.HsToCore.Pmc.Solver + , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot + , vi_rcm = emptyRCM + } + +lookupVarInfo :: TmState -> Id -> VarInfo +-- (lookupVarInfo tms x) tells what we know about 'x' +lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x) + +-- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks +-- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the +-- returned @y@ doesn't have a positive newtype constructor constraint +-- associated with it (yet). The 'VarInfo' returned is that of @y@'s +-- representative. +-- +-- Careful, this means that @idType x@ might be different to @idType y@, even +-- modulo type normalisation! +-- +-- See also Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver. +lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo) +lookupVarInfoNT ts x = case lookupVarInfo ts x of + VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y + res -> (x, res) + where + as_newtype = listToMaybe . mapMaybe go + go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]} + | isNewDataCon dc = Just y + go _ = Nothing + +trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla) +trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x + = set_vi <$> f (lookupVarInfo ts x) + where + set_vi (a, vi') = + (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } }) + +------------------------------------------------ +-- * Exported utility functions querying 'Nabla' + +lookupRefuts :: Nabla -> Id -> [PmAltCon] +-- Unfortunately we need the extra bit of polymorphism and the unfortunate +-- duplication of lookupVarInfo here. +lookupRefuts MkNabla{ nabla_tm_st = ts } x = + pmAltConSetElems $ vi_neg $ lookupVarInfo ts x + +isDataConSolution :: PmAltConApp -> Bool +isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True +isDataConSolution _ = False + +-- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from +-- possibly many, preferring 'RealDataCon' solutions whenever possible. +lookupSolution :: Nabla -> Id -> Maybe PmAltConApp +lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of + [] -> Nothing + pos + | Just sol <- find isDataConSolution pos -> Just sol + | otherwise -> Just (head pos) + -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that -- sits between Hs and Core. We need a reliable way to detect and determine @@ -434,7 +509,7 @@ pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys -- | Is a match on this constructor forcing the match variable? -- True of data constructors, literals and pattern synonyms (#17357), but not of -- newtypes. --- See Note [Coverage checking Newtype matches] in "GHC.HsToCore.Pmc.Solver". +-- See Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver. isPmAltConMatchStrict :: PmAltCon -> Bool isPmAltConMatchStrict PmAltLit{} = True isPmAltConMatchStrict (PmAltConLike PatSynCon{}) = True -- #17357 diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 3a70bc18d6..cd7bee26ef 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -34,6 +34,7 @@ import GHC.Platform import GHC.Driver.Session +import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad @@ -330,15 +331,14 @@ repTopDs group@(HsGroup { hs_valds = valds } where no_splice (L loc _) - = notHandledL (locA loc) "Splices within declaration brackets" empty + = notHandledL (locA loc) ThSplicesWithinDeclBrackets no_default_decl (L loc decl) - = notHandledL (locA loc) "Default declarations" (ppr decl) + = notHandledL (locA loc) (ThDefaultDeclarations decl) no_warn :: LWarnDecl GhcRn -> MetaM a no_warn (L loc (Warning _ thing _)) - = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $ - text "Pragma for declaration of" <+> ppr thing + = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing) no_doc (L loc _) - = notHandledL (locA loc) "Haddock documentation" empty + = notHandledL (locA loc) ThHaddockDocumentation hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes] @@ -530,9 +530,7 @@ repDataDefn tc opts ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:" - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) + (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons)) (DataType, _) -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL @@ -564,7 +562,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info addTyClTyVarBinds resTyVar $ \_ -> case info of ClosedTypeFamily Nothing -> - notHandled "abstract closed type family" (ppr decl) + notHandled (ThAbstractClosedTypeFamily decl) ClosedTypeFamily (Just eqns) -> do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns ; eqns2 <- coreListM tySynEqnTyConName eqns1 @@ -755,7 +753,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ return (locA loc, dec) where conv_cimportspec (CLabel cls) - = notHandled "Foreign label" (doubleQuotes (ppr cls)) + = notHandled (ThForeignLabel cls) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" conv_cimportspec (CFunction (StaticTarget _ fs _ True)) = return (unpackFS fs) @@ -770,7 +768,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ chStr = case mch of Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " _ -> "" -repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl) +repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl) repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) repCCallConv CCallConv = rep2_nw cCallName [] @@ -997,8 +995,8 @@ rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc) -rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas +rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty (locA loc) @@ -1118,7 +1116,7 @@ repInline :: InlineSpec -> MetaM (Core TH.Inline) repInline NoInline = dataCon noInlineDataConName repInline Inline = dataCon inlineDataConName repInline Inlinable = dataCon inlinableDataConName -repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty +repInline NoUserInlinePrag = notHandled ThNoUserInline repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName @@ -1416,7 +1414,7 @@ repTy (HsIParamTy _ n t) = do t' <- repLTy t repTImplicitParam n' t' -repTy ty = notHandled "Exotic form of type" (ppr ty) +repTy ty = notHandled (ThExoticFormOfType ty) repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] @@ -1552,7 +1550,7 @@ repE e@(HsDo _ ctxt (L _ sts)) wrapGenSyms ss e' } | otherwise - = notHandled "monad comprehension and [: :]" (ppr e) + = notHandled (ThMonadComprehensionSyntax e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = @@ -1625,8 +1623,8 @@ repE (XExpr (HsExpanded orig_expr ds_expr)) then repE ds_expr else repE orig_expr } -repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled "Cost centres" (ppr e) -repE e = notHandled "Expression form" (ppr e) +repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) +repE e = notHandled (ThExpressionForm e) {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1717,7 +1715,7 @@ repUpdFields = repListM fieldExpTyConName rep_fld Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } - Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld) + Ambiguous{} -> notHandled (ThAmbiguousRecordUpdates fld) @@ -1798,7 +1796,7 @@ repSts (stmt@RecStmt{} : ss) ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } repSts [] = return ([],[]) -repSts other = notHandled "Exotic statement" (ppr other) +repSts other = notHandled (ThExoticStatement other) ----------------------------------------------------------- @@ -2016,7 +2014,7 @@ repLambda (L _ (Match { m_pats = ps do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) +repLambda (L _ m) = notHandled (ThGuardedLambdas m) ----------------------------------------------------------------------------- @@ -2072,12 +2070,12 @@ repP (ConPat NoExtField dc details) repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p) repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice -repP other = notHandled "Exotic pattern" (ppr other) +repP other = notHandled (ThExoticPattern other) ---------------------------------------------------------- -- Declaration ordering helpers @@ -2841,7 +2839,7 @@ repLiteral lit lit_expr <- lift $ dsLit lit' case mb_lit_name of Just lit_name -> rep2_nw lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) + Nothing -> notHandled (ThExoticLiteral lit) where mb_lit_name = case lit of HsInteger _ _ _ -> Just integerLName @@ -3008,15 +3006,12 @@ coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) ----------------- Failure ----------------------- -notHandledL :: SrcSpan -> String -> SDoc -> MetaM a -notHandledL loc what doc +notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a +notHandledL loc reason | isGoodSrcSpan loc - = mapReaderT (putSrcSpanDs loc) $ notHandled what doc + = mapReaderT (putSrcSpanDs loc) $ notHandled reason | otherwise - = notHandled what doc + = notHandled reason -notHandled :: String -> SDoc -> MetaM a -notHandled what doc = lift $ failWithDs msg - where - msg = hang (text what <+> text "not (yet) handled by Template Haskell") - 2 doc +notHandled :: ThRejectionReason -> MetaM a +notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason) diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 6b08ae0877..725d99fea4 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -13,6 +13,7 @@ import GHC.Parser.Errors.Types import GHC.Parser.Types import GHC.Types.Basic import GHC.Types.Error +import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) @@ -774,6 +775,3 @@ pp_unexpected_fun_app e a = parse_error_in_pat :: SDoc parse_error_in_pat = text "Parse error in pattern:" - -perhapsAsPat :: SDoc -perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 650befdd8f..a44309eaf6 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -2,12 +2,17 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage module GHC.Tc.Errors.Ppr ( + formatLevPolyErr + , pprLevityPolyInType ) where import GHC.Prelude +import GHC.Core.TyCo.Ppr (pprWithTYPE) +import GHC.Core.Type import GHC.Tc.Errors.Types import GHC.Types.Error +import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Driver.Flags import GHC.Hs import GHC.Utils.Outputable @@ -16,6 +21,8 @@ instance Diagnostic TcRnMessage where diagnosticMessage = \case TcRnUnknownMessage m -> diagnosticMessage m + TcLevityPolyInType ty prov (ErrInfo extra) + -> mkDecorated [pprLevityPolyInType ty prov, extra] TcRnImplicitLift id_or_name errInfo -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+> text "is implicitly lifted in the TH quotation" @@ -35,6 +42,8 @@ instance Diagnostic TcRnMessage where diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m + TcLevityPolyInType{} + -> ErrorWithoutFlag TcRnImplicitLift{} -> WarningWithFlag Opt_WarnImplicitLift TcRnUnusedPatternBinds{} @@ -49,6 +58,8 @@ instance Diagnostic TcRnMessage where diagnosticHints = \case TcRnUnknownMessage m -> diagnosticHints m + TcLevityPolyInType{} + -> noHints TcRnImplicitLift{} -> noHints TcRnUnusedPatternBinds{} @@ -73,3 +84,44 @@ dodgy_msg_insert tc = IEThingAll noAnn ii where ii :: LIEWrappedName (IdP (GhcPass p)) ii = noLocA (IEName $ noLocA tc) + +formatLevPolyErr :: Type -- levity-polymorphic type + -> SDoc +formatLevPolyErr ty + = hang (text "A levity-polymorphic type is not allowed here:") + 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty + , text "Kind:" <+> pprWithTYPE tidy_ki ]) + where + (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty + tidy_ki = tidyType tidy_env (tcTypeKind ty) + +pprLevityPolyInType :: Type -> LevityCheckProvenance -> SDoc +pprLevityPolyInType ty prov = + let extra = case prov of + LevityCheckInBinder v + -> text "In the type of binder" <+> quotes (ppr v) + LevityCheckInVarType + -> text "When trying to create a variable of type:" <+> ppr ty + LevityCheckInWildcardPattern + -> text "In a wildcard pattern" + LevityCheckInUnboxedTuplePattern p + -> text "In the type of an element of an unboxed tuple pattern:" $$ ppr p + LevityCheckPatSynSig + -> empty + LevityCheckCmdStmt + -> empty -- I (Richard E, Dec '16) have no idea what to say here + LevityCheckMkCmdEnv id_var + -> text "In the result of the function" <+> quotes (ppr id_var) + LevityCheckDoCmd do_block + -> text "In the do-command:" <+> ppr do_block + LevityCheckDesugaringCmd cmd + -> text "When desugaring the command:" <+> ppr cmd + LevityCheckInCmd body + -> text "In the command:" <+> ppr body + LevityCheckInFunUse using + -> text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using + LevityCheckInValidDataCon + -> empty + LevityCheckInValidClass + -> empty + in formatLevPolyErr ty $$ extra diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 6da4cd6613..b0deeaaf2c 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) , ErrInfo(..) + , LevityCheckProvenance(..) ) where import GHC.Hs @@ -11,6 +13,7 @@ import GHC.Types.Name (Name) import GHC.Types.Name.Reader import GHC.Utils.Outputable import Data.Typeable +import GHC.Core.Type (Type, Var) -- The majority of TcRn messages come with extra context about the error, -- and this newtype captures it. @@ -22,6 +25,15 @@ data TcRnMessage where to provide custom diagnostic messages originated during typechecking/renaming. -} TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage + + {-| A levity polymorphism check happening during TcRn. + -} + TcLevityPolyInType :: !Type + -> !LevityCheckProvenance + -> !ErrInfo -- Extra info accumulated in the TcM monad + -> TcRnMessage + + {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when a Template Haskell quote implicitly uses 'lift'. @@ -76,3 +88,21 @@ data TcRnMessage where Test cases: rename/should_compile/T4489 -} TcRnMissingImportList :: IE GhcPs -> TcRnMessage + + +-- | Where the levity checking for the input type originated +data LevityCheckProvenance + = LevityCheckInVarType + | LevityCheckInBinder !Var + | LevityCheckInWildcardPattern + | LevityCheckInUnboxedTuplePattern !(Pat GhcTc) + | LevityCheckPatSynSig + | LevityCheckCmdStmt + | LevityCheckMkCmdEnv !Var + | LevityCheckDoCmd !(HsCmd GhcTc) + | LevityCheckDesugaringCmd !(LHsCmd GhcTc) + | LevityCheckInCmd !(LHsCmd GhcTc) + | LevityCheckInFunUse !(LHsExpr GhcTc) + | LevityCheckInValidDataCon + | LevityCheckInValidClass + diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index ffe2e4ecdd..6edb614884 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -27,6 +27,7 @@ module GHC.Tc.Gen.Sig( import GHC.Prelude import GHC.Hs +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) @@ -445,7 +446,7 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here ; let (arg_tys, _) = tcSplitFunTys body_ty - ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys + ; mapM_ (checkForLevPoly LevityCheckPatSynSig . scaledThing) arg_tys ; traceTc "tcTySig }" $ vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index d0a511ccfa..8c23fef1cf 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -33,6 +33,7 @@ import GHC.Driver.Session import GHC.Hs +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -4368,7 +4369,7 @@ checkValidDataCon dflags existential_ok tc con -- better error message than checkForLevPoly would. ; unless (isNewTyCon tc) $ checkNoErrs $ - mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con) + mapM_ (checkForLevPoly LevityCheckInValidDataCon) (map scaledThing $ dataConOrigArgTys con) -- the checkNoErrs is to prevent a panic in isVanillaDataCon -- (called a a few lines down), which can fall over if there is a -- bang on a levity-polymorphic argument. This is #18534, @@ -4573,7 +4574,7 @@ checkValidClass cls -- example of what this prevents: -- class BoundedX (a :: TYPE r) where minBound :: a -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - ; checkForLevPoly empty tau1 + ; checkForLevPoly LevityCheckInValidClass tau1 ; unless constrained_class_methods $ mapM_ check_constraint (tail (cls_pred:op_theta)) diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index f24f949923..ccebfd6716 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -93,7 +93,7 @@ module GHC.Tc.Utils.TcMType ( ------------------------------ -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr + ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, ) where -- friends: @@ -110,6 +110,7 @@ import GHC.Core.Coercion import GHC.Core.Class import GHC.Types.Var import GHC.Core.Predicate +import GHC.Tc.Errors.Types import GHC.Tc.Types.Origin -- others: @@ -2624,36 +2625,28 @@ See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -- isn't really a compositional property of a type system, so it's -- not a terrible surprise that the check has to go in an awkward spot. ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened + -> LevityCheckProvenance -- where this happened -> TcM () -ensureNotLevPoly ty doc +ensureNotLevPoly ty provenance = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty + checkForLevPoly provenance ty -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr +checkForLevPoly :: LevityCheckProvenance -> Type -> TcM () +checkForLevPoly = checkForLevPolyX (\ty -> addDetailedDiagnostic . TcLevityPolyInType ty) checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty + => (Type -> LevityCheckProvenance -> m ()) -- how to report an error + -> LevityCheckProvenance + -> Type + -> m () +checkForLevPolyX add_err provenance ty | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) + = add_err ty provenance | otherwise = return () -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty - , text "Kind:" <+> pprWithTYPE tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) - {- %************************************************************************ %* * diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 9207e1805f..7755ff0f14 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -53,6 +53,7 @@ import GHC.Builtin.Names import GHC.Hs +import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) @@ -444,8 +445,7 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) + ensureNotLevPoly ty' (LevityCheckInBinder v) return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) @@ -1418,8 +1418,7 @@ zonk_pat env (ParPat x lpar p rpar) zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") + ; ensureNotLevPoly ty' LevityCheckInWildcardPattern ; return (env, WildPat ty') } zonk_pat env (VarPat x (L l v)) @@ -1485,7 +1484,7 @@ zonk_pat env p@(ConPat { pat_con = L _ con ; case con of RealDataCon dc | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) + -> mapM_ (checkForLevPoly (LevityCheckInUnboxedTuplePattern p)) (dropRuntimeRepArgs new_tys) _ -> return () ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars @@ -1509,8 +1508,6 @@ zonk_pat env p@(ConPat { pat_con = L _ con } ) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p zonk_pat env (LitPat x lit) = return (env, LitPat x lit) diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 51cd77b33a..475e0ee6fb 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -1,13 +1,20 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -module GHC.Types.Hint where -import GHC.Prelude +module GHC.Types.Hint ( + GhcHint(..), + InstantiationSuggestion(..) + ) where import GHC.Utils.Outputable -import GHC.LanguageExtensions +import qualified GHC.LanguageExtensions as LangExt import Data.Typeable import GHC.Unit.Module (ModuleName, Module) +import GHC.Hs.Extension (GhcTc) +import GHC.Types.Var (Var) +import GHC.Types.Basic (Activation, RuleName) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr + -- This {-# SOURCE #-} import should be removable once + -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'. -- | A type for hints emitted by GHC. -- A /hint/ suggests a possible way to deal with a particular warning or error. @@ -29,7 +36,7 @@ data GhcHint parser/should_fail/T18251e, ... (and many more) -} - | SuggestExtension !Extension + | SuggestExtension !LangExt.Extension {-| Suggests that a monadic code block is probably missing a \"do\" keyword. Example: @@ -68,51 +75,46 @@ data GhcHint Test case(s): driver/T12955 -} | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion] - {-| Suggests to use spaces instead of tabs. + {-| Suggests to use spaces instead of tabs. - Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'. + Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'. - Examples: None - Test Case(s): None - -} + Examples: None + Test Case(s): None + -} | SuggestUseSpaces - {-| Suggests wrapping an expression in parentheses + {-| Suggests wrapping an expression in parentheses - Examples: None - Test Case(s): None - -} + Examples: None + Test Case(s): None + -} | SuggestParentheses + {-| Suggests to increase the -fmax-pmcheck-models limit for the pattern match checker. + + Triggered by: 'GHC.HsToCore.Errors.Types.DsMaxPmCheckModelsReached' + + Test case(s): pmcheck/should_compile/TooManyDeltas + pmcheck/should_compile/TooManyDeltas + pmcheck/should_compile/T11822 + -} + | SuggestIncreaseMaxPmCheckModels + {-| Suggests adding a type signature, typically to resolve ambiguity or help GHC inferring types. + + -} + | SuggestAddTypeSignature + {-| Suggests to explicitly discard the result of a monadic action by binding the result to + the '_' wilcard. + + Example: + main = do + _ <- getCurrentTime + + -} + | SuggestBindToWildcard !(LHsExpr GhcTc) + | SuggestAddInlineOrNoInlinePragma !Var !Activation -instance Outputable GhcHint where - ppr = \case - UnknownHint m - -> ppr m - SuggestExtension ext - -> text "Perhaps you intended to use" <+> ppr ext - SuggestMissingDo - -> text "Possibly caused by a missing 'do'?" - SuggestLetInDo - -> text "Perhaps you need a 'let' in a 'do' block?" - $$ text "e.g. 'let x = 5' instead of 'x = 5'" - SuggestAddSignatureCabalFile pi_mod_name - -> text "Try adding" <+> quotes (ppr pi_mod_name) - <+> text "to the" - <+> quotes (text "signatures") - <+> text "field in your Cabal file." - SuggestSignatureInstantiations pi_mod_name suggestions - -> let suggested_instantiated_with = - hcat (punctuate comma $ - [ ppr k <> text "=" <> ppr v - | InstantiationSuggestion k v <- suggestions - ]) - in text "Try passing -instantiated-with=\"" <> - suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr pi_mod_name <> text "> as necessary." - SuggestUseSpaces - -> text "Please use spaces instead." - SuggestParentheses - -> text "Use parentheses." + | SuggestAddPhaseToCompetingRule !RuleName -- | 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 new file mode 100644 index 0000000000..ad8c614c16 --- /dev/null +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- instance Outputable GhcHint + +module GHC.Types.Hint.Ppr ( + perhapsAsPat + -- also, and more interesting: instance Outputable GhcHint + ) where + +import GHC.Prelude + +import GHC.Types.Hint + +import GHC.Hs.Expr () -- instance Outputable +import GHC.Types.Id +import GHC.Utils.Outputable +import qualified GHC.LanguageExtensions as LangExt + +instance Outputable GhcHint where + ppr = \case + UnknownHint m + -> ppr m + SuggestExtension ext + -> case ext of + LangExt.NegativeLiterals + -> text "If you are trying to write a large negative literal, use NegativeLiterals" + _ -> text "Perhaps you intended to use" <+> ppr ext + SuggestMissingDo + -> text "Possibly caused by a missing 'do'?" + SuggestLetInDo + -> text "Perhaps you need a 'let' in a 'do' block?" + $$ text "e.g. 'let x = 5' instead of 'x = 5'" + SuggestAddSignatureCabalFile pi_mod_name + -> text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file." + SuggestSignatureInstantiations pi_mod_name suggestions + -> let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | InstantiationSuggestion k v <- suggestions + ]) + in text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary." + SuggestUseSpaces + -> text "Please use spaces instead." + SuggestParentheses + -> text "Use parentheses." + SuggestIncreaseMaxPmCheckModels + -> text "Increase the limit or resolve the warnings to suppress this message." + SuggestAddTypeSignature + -> text "Add a type signature." + SuggestBindToWildcard rhs + -> hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs) + SuggestAddInlineOrNoInlinePragma lhs_id rule_act + -> vcat [ text "Add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) + ] + SuggestAddPhaseToCompetingRule bad_rule + -> vcat [ text "Add phase [n] or [~n] to the competing rule" + , whenPprDebug (ppr bad_rule) ] + +perhapsAsPat :: SDoc +perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index fae95343f6..40cfde0d3a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -643,6 +643,7 @@ Library GHC.Types.ForeignCall GHC.Types.ForeignStubs GHC.Types.Hint + GHC.Types.Hint.Ppr GHC.Types.HpcInfo GHC.Types.Id GHC.Types.IPE diff --git a/testsuite/tests/deSugar/should_compile/T10662.stderr b/testsuite/tests/deSugar/should_compile/T10662.stderr index 6a5cc457fc..e1f8c75c17 100644 --- a/testsuite/tests/deSugar/should_compile/T10662.stderr +++ b/testsuite/tests/deSugar/should_compile/T10662.stderr @@ -1,5 +1,6 @@ T10662.hs:3:3: warning: [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘String’ - Suppress this warning by saying - ‘_ <- return $ let a = "hello" in a’ + Suggested fix: + Suppress this warning by saying + ‘_ <- return $ let a = "hello" in a’ diff --git a/testsuite/tests/deSugar/should_compile/T3263-1.stderr b/testsuite/tests/deSugar/should_compile/T3263-1.stderr index a50f8933aa..acc59ab3cd 100644 --- a/testsuite/tests/deSugar/should_compile/T3263-1.stderr +++ b/testsuite/tests/deSugar/should_compile/T3263-1.stderr @@ -1,8 +1,10 @@ T3263-1.hs:25:3: warning: [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ - Suppress this warning by saying ‘_ <- nonNullM’ + Suggested fix: + Suppress this warning by saying ‘_ <- nonNullM’ T3263-1.hs:35:3: warning: [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ - Suppress this warning by saying ‘_ <- nonNullM’ + Suggested fix: + Suppress this warning by saying ‘_ <- nonNullM’ diff --git a/testsuite/tests/deSugar/should_compile/T3263-2.stderr b/testsuite/tests/deSugar/should_compile/T3263-2.stderr index 83de241f50..32c3bc3ad8 100644 --- a/testsuite/tests/deSugar/should_compile/T3263-2.stderr +++ b/testsuite/tests/deSugar/should_compile/T3263-2.stderr @@ -1,8 +1,10 @@ T3263-2.hs:25:3: warning: [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ - Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ + Suggested fix: + Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ T3263-2.hs:37:3: warning: [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ - Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ + Suggested fix: + Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ diff --git a/testsuite/tests/driver/recomp005/recomp005.stderr b/testsuite/tests/driver/recomp005/recomp005.stderr index f1c81418a2..9a966f977b 100644 --- a/testsuite/tests/driver/recomp005/recomp005.stderr +++ b/testsuite/tests/driver/recomp005/recomp005.stderr @@ -1,9 +1,11 @@ C.hs:7:11: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "f/g" may never fire because ‘g’ might inline first - Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘g’ + Suggested fix: + Add an INLINE[n] or NOINLINE[n] pragma for ‘g’ C.hs:7:11: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "f/g" may never fire because ‘f’ might inline first - Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘f’ + Suggested fix: + Add an INLINE[n] or NOINLINE[n] pragma for ‘f’ diff --git a/testsuite/tests/ghci/scripts/T3263.stderr b/testsuite/tests/ghci/scripts/T3263.stderr index df58a5dc58..dd72b3f31b 100644 --- a/testsuite/tests/ghci/scripts/T3263.stderr +++ b/testsuite/tests/ghci/scripts/T3263.stderr @@ -1,4 +1,5 @@ T3263.hs:8:12: warning: [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Char’ - Suppress this warning by saying ‘_ <- getChar’ + Suggested fix: + Suppress this warning by saying ‘_ <- getChar’ diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout index 85406d04b6..584803afbc 100644 --- a/testsuite/tests/ghci/scripts/T9140.stdout +++ b/testsuite/tests/ghci/scripts/T9140.stdout @@ -1,11 +1,11 @@ <interactive>:2:5: error: You can't mix polymorphic and unlifted bindings: a = (# 1 #) - Probable fix: add a type signature + Suggested fix: Add a type signature. <interactive>:3:5: error: You can't mix polymorphic and unlifted bindings: a = (# 1, 3 #) - Probable fix: add a type signature + Suggested fix: Add a type signature. <interactive>:1:1: error: GHCi can't bind a variable of unlifted type: diff --git a/testsuite/tests/numeric/should_compile/T8542.stderr b/testsuite/tests/numeric/should_compile/T8542.stderr index 699ba5d573..fb6ddf7a72 100644 --- a/testsuite/tests/numeric/should_compile/T8542.stderr +++ b/testsuite/tests/numeric/should_compile/T8542.stderr @@ -1,4 +1,5 @@ T8542.hs:9:5: warning: [-Woverflowed-literals (in -Wdefault)] Literal 128 is out of the Int8 range -128..127 - If you are trying to write a large negative literal, use NegativeLiterals + Suggested fix: + If you are trying to write a large negative literal, use NegativeLiterals diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index d17ccda974..4b33ad2982 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 258 Language.Haskell.Syntax module dependencies +Found 266 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -31,6 +31,7 @@ GHC.Core.FamInstEnv GHC.Core.InstEnv GHC.Core.Lint GHC.Core.Make +GHC.Core.Map.Expr GHC.Core.Map.Type GHC.Core.Multiplicity GHC.Core.Opt.Arity @@ -108,6 +109,9 @@ GHC.Hs.Type GHC.Hs.Utils GHC.HsToCore.Errors.Ppr GHC.HsToCore.Errors.Types +GHC.HsToCore.Pmc.Ppr +GHC.HsToCore.Pmc.Solver.Types +GHC.HsToCore.Pmc.Types GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax @@ -148,6 +152,8 @@ GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes GHC.Tc.Errors.Ppr GHC.Tc.Errors.Types +GHC.Tc.Solver.InertSet +GHC.Tc.Solver.Types GHC.Tc.Types GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence @@ -168,6 +174,7 @@ GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs GHC.Types.Hint +GHC.Types.Hint.Ppr GHC.Types.HpcInfo GHC.Types.IPE GHC.Types.Id @@ -197,6 +204,7 @@ GHC.Types.Unique.DFM GHC.Types.Unique.DSet GHC.Types.Unique.FM GHC.Types.Unique.Map +GHC.Types.Unique.SDFM GHC.Types.Unique.Set GHC.Types.Unique.Supply GHC.Types.Var diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index c9080fbce3..16dbb8e185 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 264 GHC.Parser module dependencies +Found 272 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -31,6 +31,7 @@ GHC.Core.FamInstEnv GHC.Core.InstEnv GHC.Core.Lint GHC.Core.Make +GHC.Core.Map.Expr GHC.Core.Map.Type GHC.Core.Multiplicity GHC.Core.Opt.Arity @@ -109,6 +110,9 @@ GHC.Hs.Type GHC.Hs.Utils GHC.HsToCore.Errors.Ppr GHC.HsToCore.Errors.Types +GHC.HsToCore.Pmc.Ppr +GHC.HsToCore.Pmc.Solver.Types +GHC.HsToCore.Pmc.Types GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax @@ -154,6 +158,8 @@ GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes GHC.Tc.Errors.Ppr GHC.Tc.Errors.Types +GHC.Tc.Solver.InertSet +GHC.Tc.Solver.Types GHC.Tc.Types GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence @@ -174,6 +180,7 @@ GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs GHC.Types.Hint +GHC.Types.Hint.Ppr GHC.Types.HpcInfo GHC.Types.IPE GHC.Types.Id @@ -203,6 +210,7 @@ GHC.Types.Unique.DFM GHC.Types.Unique.DSet GHC.Types.Unique.FM GHC.Types.Unique.Map +GHC.Types.Unique.SDFM GHC.Types.Unique.Set GHC.Types.Unique.Supply GHC.Types.Var diff --git a/testsuite/tests/pmcheck/should_compile/T11822.stderr b/testsuite/tests/pmcheck/should_compile/T11822.stderr index 8ad52e6de4..212d300537 100644 --- a/testsuite/tests/pmcheck/should_compile/T11822.stderr +++ b/testsuite/tests/pmcheck/should_compile/T11822.stderr @@ -19,5 +19,6 @@ T11822.hs:33:1: warning: • Redundant clauses might not be reported at all • Redundant clauses might be reported as inaccessible • Patterns reported as unmatched might actually be matched - Increase the limit or resolve the warnings to suppress this message. + Suggested fix: + Increase the limit or resolve the warnings to suppress this message. diff --git a/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr b/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr index cb65b8cab4..9297e1b669 100644 --- a/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr +++ b/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr @@ -13,14 +13,16 @@ TooManyDeltas.hs:14:1: warning: • Redundant clauses might not be reported at all • Redundant clauses might be reported as inaccessible • Patterns reported as unmatched might actually be matched - Increase the limit or resolve the warnings to suppress this message. + Suggested fix: + Increase the limit or resolve the warnings to suppress this message. TooManyDeltas.hs:19:1: warning: Pattern match checker ran into -fmax-pmcheck-models=0 limit, so • Redundant clauses might not be reported at all • Redundant clauses might be reported as inaccessible • Patterns reported as unmatched might actually be matched - Increase the limit or resolve the warnings to suppress this message. + Suggested fix: + Increase the limit or resolve the warnings to suppress this message. TooManyDeltas.hs:20:1: warning: [-Woverlapping-patterns (in -Wdefault)] Pattern match has inaccessible right hand side diff --git a/testsuite/tests/rename/should_compile/T2600.stderr b/testsuite/tests/rename/should_compile/T2600.stderr index ca675475cf..64ef6e9e82 100644 --- a/testsuite/tests/rename/should_compile/T2600.stderr +++ b/testsuite/tests/rename/should_compile/T2600.stderr @@ -2,10 +2,12 @@ T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "myrule" may never fire because rule "Class op to" for ‘to’ might fire first - Probable fix: add phase [n] or [~n] to the competing rule + Suggested fix: + Add phase [n] or [~n] to the competing rule T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "myrule" may never fire because rule "Class op tmap" for ‘tmap’ might fire first - Probable fix: add phase [n] or [~n] to the competing rule + Suggested fix: + Add phase [n] or [~n] to the competing rule diff --git a/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr b/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr index 7359861750..3a3332769e 100644 --- a/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr +++ b/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr @@ -1,8 +1,10 @@ T6082-RULE.hs:5:11: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "foo1" may never fire because ‘foo1’ might inline first - Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’ + Suggested fix: + Add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’ T6082-RULE.hs:10:11: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "foo2" may never fire because ‘foo2’ might inline first - Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’ + Suggested fix: + Add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’ diff --git a/testsuite/tests/simplCore/should_compile/T7287.stderr b/testsuite/tests/simplCore/should_compile/T7287.stderr index 5aa71e0e98..957282b8f3 100644 --- a/testsuite/tests/simplCore/should_compile/T7287.stderr +++ b/testsuite/tests/simplCore/should_compile/T7287.stderr @@ -2,4 +2,5 @@ T7287.hs:7:3: warning: [-Winline-rule-shadowing (in -Wdefault)] Rule "int2Word#/word2Int#" may never fire because rule "word2Int#" for ‘word2Int#’ might fire first - Probable fix: add phase [n] or [~n] to the competing rule + Suggested fix: + Add phase [n] or [~n] to the competing rule diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr index 62a4210443..65f5df765e 100644 --- a/testsuite/tests/typecheck/should_fail/T6078.stderr +++ b/testsuite/tests/typecheck/should_fail/T6078.stderr @@ -2,4 +2,4 @@ T6078.hs:8:10: error: You can't mix polymorphic and unlifted bindings: ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len - Probable fix: add a type signature + Suggested fix: Add a type signature. |