summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/HsToCore.hs22
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs16
-rw-r--r--compiler/GHC/HsToCore/Binds.hs53
-rw-r--r--compiler/GHC/HsToCore/Errors/Ppr.hs356
-rw-r--r--compiler/GHC/HsToCore/Errors/Types.hs207
-rw-r--r--compiler/GHC/HsToCore/Expr.hs58
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs4
-rw-r--r--compiler/GHC/HsToCore/Match.hs11
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs39
-rw-r--r--compiler/GHC/HsToCore/Monad.hs61
-rw-r--r--compiler/GHC/HsToCore/Pmc.hs67
-rw-r--r--compiler/GHC/HsToCore/Pmc/Ppr.hs3
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver.hs76
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver/Types.hs79
-rw-r--r--compiler/GHC/HsToCore/Quote.hs61
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs4
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs52
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs30
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs3
-rw-r--r--compiler/GHC/Tc/TyCl.hs5
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs33
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs11
-rw-r--r--compiler/GHC/Types/Hint.hs88
-rw-r--r--compiler/GHC/Types/Hint/Ppr.hs66
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--testsuite/tests/deSugar/should_compile/T10662.stderr5
-rw-r--r--testsuite/tests/deSugar/should_compile/T3263-1.stderr6
-rw-r--r--testsuite/tests/deSugar/should_compile/T3263-2.stderr6
-rw-r--r--testsuite/tests/driver/recomp005/recomp005.stderr6
-rw-r--r--testsuite/tests/ghci/scripts/T3263.stderr3
-rw-r--r--testsuite/tests/ghci/scripts/T9140.stdout4
-rw-r--r--testsuite/tests/numeric/should_compile/T8542.stderr3
-rw-r--r--testsuite/tests/parser/should_run/CountAstDeps.stdout10
-rw-r--r--testsuite/tests/parser/should_run/CountParserDeps.stdout10
-rw-r--r--testsuite/tests/pmcheck/should_compile/T11822.stderr3
-rw-r--r--testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr6
-rw-r--r--testsuite/tests/rename/should_compile/T2600.stderr6
-rw-r--r--testsuite/tests/simplCore/should_compile/T6082-RULE.stderr6
-rw-r--r--testsuite/tests/simplCore/should_compile/T7287.stderr3
-rw-r--r--testsuite/tests/typecheck/should_fail/T6078.stderr2
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.