diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 2586559d11cc8cb78216dd55be695efa78ccf58a..857e02e3734458971c782b93822a2f6f1cd39d6e 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1175,7 +1175,7 @@ reportGroup mk_err ctxt items
-- See Note [No deferring for multiplicity errors]
nonDeferrableOrigin :: CtOrigin -> Bool
-nonDeferrableOrigin NonLinearPatternOrigin = True
+nonDeferrableOrigin (NonLinearPatternOrigin {}) = True
nonDeferrableOrigin (UsageEnvironmentOf {}) = True
nonDeferrableOrigin (FRROrigin {}) = True
nonDeferrableOrigin _ = False
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 68f1edfbd1e38f47922d5ec86fb4cb7d6f12b056..c9018253950e6924bef45bd48d0bf78ee0e05109 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -804,7 +804,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list
manyIfPat bind@(L _ (PatBind{pat_lhs=(L _ (VarPat{}))}))
= return bind
manyIfPat (L loc pat@(PatBind {pat_mult=mult_ann, pat_lhs=lhs, pat_ext =(pat_ty,_)}))
- = do { mult_co_wrap <- tcSubMult NonLinearPatternOrigin ManyTy (getTcMultAnn mult_ann)
+ = do { mult_co_wrap <- tcSubMult (NonLinearPatternOrigin GeneralisedPatternReason nlWildPatName) ManyTy (getTcMultAnn mult_ann)
-- The wrapper checks for correct multiplicities.
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; let lhs' = mkLHsWrapPat mult_co_wrap lhs pat_ty
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 9ec72d27ac1f9bea6279426daba14f82747f5016..99ffe6561bf2ba4612cc066423056438fab38726 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -114,14 +114,14 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
| xopt LangExt.Strict dflags = xstrict lpat
| otherwise = not_xstrict lpat
where
- xstrict (L _ (LazyPat _ _)) = checkManyPattern pat_ty
+ xstrict p@(L _ (LazyPat _ _)) = checkManyPattern LazyPatternReason p pat_ty
xstrict (L _ (ParPat _ p)) = xstrict p
xstrict _ = return WpHole
not_xstrict (L _ (BangPat _ _)) = return WpHole
not_xstrict (L _ (VarPat _ _)) = return WpHole
not_xstrict (L _ (ParPat _ p)) = not_xstrict p
- not_xstrict _ = checkManyPattern pat_ty
+ not_xstrict p = checkManyPattern LazyPatternReason p pat_ty
-----------------
tcMatchPats :: forall a.
@@ -467,8 +467,8 @@ tc_lpats tys penv pats
--------------------
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-checkManyPattern :: Scaled a -> TcM HsWrapper
-checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty)
+checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM HsWrapper
+checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pat) ManyTy (scaledMult pat_ty)
tc_forall_lpat :: TcTyVar -> Checker (LPat GhcRn) (LPat GhcTc)
@@ -582,7 +582,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; return (BangPat x pat', res) }
LazyPat x pat -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; (pat', (res, pat_ct))
<- tc_lpat pat_ty (makeLazy penv) pat $
@@ -600,14 +600,14 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) }
WildPat _ -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; res <- thing_inside
; pat_ty <- expTypeToType (scaledThing pat_ty)
; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) }
AsPat x (L nm_loc name) pat -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
; (pat', res) <- tcExtendIdEnv1 name bndr_id $
@@ -624,7 +624,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
ViewPat _ expr pat -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
--
-- It should be possible to have view patterns at linear (or otherwise
@@ -790,7 +790,7 @@ Fortunately that's what matchActualFunTy returns anyway.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
NPat _ (L l over_lit) mb_neg eq -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
--
-- It may be possible to refine linear pattern so that they work in
@@ -843,7 +843,7 @@ AST is used for the subtraction operation.
-- See Note [NPlusK patterns]
NPlusKPat _ (L nm_loc name)
(L loc lit) _ ge minus -> do
- { mult_wrap <- checkManyPattern pat_ty
+ { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; let pat_exp_ty = scaledThing pat_ty
orig = LiteralOrigin lit
@@ -1225,7 +1225,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
; when (any isEqPred prov_theta) warnMonoLocalBinds
- ; mult_wrap <- checkManyPattern pat_ty
+ ; mult_wrap <- checkManyPattern PatternSynonymReason nlWildPatName pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 82e60727aa91291dde711c230754d13a0f7f8d38..aea97da224eb0468134d31b2c0befd55a138c7a7 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -22,7 +22,7 @@ module GHC.Tc.Types.Origin (
isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
isWantedSuperclassOrigin,
- ClsInstOrQC(..), NakedScFlag(..),
+ ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),
TypedThing(..), TyVarBndrs(..),
@@ -621,7 +621,7 @@ data CtOrigin
Module -- ^ Module in which the instance was declared
ClsInst -- ^ The declared typeclass instance
- | NonLinearPatternOrigin
+ | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn)
| UsageEnvironmentOf Name
| CycleBreakerOrigin
@@ -642,6 +642,12 @@ data CtOrigin
Type -- the instantiated type of the method
| AmbiguityCheckOrigin UserTypeCtxt
+data NonLinearPatternReason
+ = LazyPatternReason
+ | GeneralisedPatternReason
+ | PatternSynonymReason
+ | ViewPatternReason
+ | OtherPatternReason
-- | The number of superclass selections needed to get this Given.
-- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look
@@ -881,6 +887,10 @@ pprCtOrigin (ScOrigin (IsQC orig) nkd)
, whenPprDebug (braces (text "sc-origin:" <> ppr nkd))
, pprCtOrigin orig ]
+pprCtOrigin (NonLinearPatternOrigin reason pat)
+ = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat))
+ 2 (pprNonLinearPatternReason reason)
+
pprCtOrigin simple_origin
= ctoHerald <+> pprCtO simple_origin
@@ -921,7 +931,6 @@ pprCtO PatCheckOrigin = text "a pattern-match completeness check"
pprCtO ListOrigin = text "an overloaded list"
pprCtO IfThenElseOrigin = text "an if-then-else expression"
pprCtO StaticOrigin = text "a static form"
-pprCtO NonLinearPatternOrigin = text "a non-linear pattern"
pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
pprCtO BracketOrigin = text "a quotation bracket"
@@ -949,7 +958,14 @@ pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint"
pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance"
pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"
pprCtO (ImpedanceMatching {}) = text "combining required constraints"
-
+pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
+
+pprNonLinearPatternReason :: HasCallStack => NonLinearPatternReason -> SDoc
+pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")
+pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear")
+pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear")
+pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")
+pprNonLinearPatternReason OtherPatternReason = empty
{- *********************************************************************
* *
diff --git a/testsuite/tests/linear/should_fail/Linear9.stderr b/testsuite/tests/linear/should_fail/Linear9.stderr
index 87092b13b72e505c771e912b2da91cbd867e44f7..14e943cf2711a88887d1e80fc0da9652b8fb38a0 100644
--- a/testsuite/tests/linear/should_fail/Linear9.stderr
+++ b/testsuite/tests/linear/should_fail/Linear9.stderr
@@ -1,7 +1,7 @@
Linear9.hs:9:17: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
• In the pattern: _
In the pattern: (a, _)
In an equation for ‘incorrectFst’: incorrectFst (a, _) = a
@@ -21,14 +21,14 @@ Linear9.hs:15:20: error: [GHC-18872]
Linear9.hs:18:21: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
• In the pattern: _
In the pattern: (a, _)
In the pattern: ((a, _), _)
Linear9.hs:18:24: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
• In the pattern: _
In the pattern: ((a, _), _)
In an equation for ‘incorrectFstFst’:
@@ -36,7 +36,7 @@ Linear9.hs:18:24: error: [GHC-18872]
Linear9.hs:25:25: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
• In the pattern: _
In the pattern: Foo a _
In an equation for ‘incorrectTestFst’:
diff --git a/testsuite/tests/linear/should_fail/LinearAsPat.stderr b/testsuite/tests/linear/should_fail/LinearAsPat.stderr
index 987993d8970f2e5c43f8562a920f2dcaefaeca4a..0aea88e4cd3592d7f38e74c15f191873f402c345 100644
--- a/testsuite/tests/linear/should_fail/LinearAsPat.stderr
+++ b/testsuite/tests/linear/should_fail/LinearAsPat.stderr
@@ -1,5 +1,5 @@
LinearAsPat.hs:6:12: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘x@True’
• In an equation for ‘shouldFail’: shouldFail x@True = x
diff --git a/testsuite/tests/linear/should_fail/LinearLazyPat.stderr b/testsuite/tests/linear/should_fail/LinearLazyPat.stderr
index 82fb02725b4bc6a985059654beb12eb410574718..a53bdfe4c0b74bebb9461f23f5981918d2fb8758 100644
--- a/testsuite/tests/linear/should_fail/LinearLazyPat.stderr
+++ b/testsuite/tests/linear/should_fail/LinearLazyPat.stderr
@@ -1,6 +1,7 @@
LinearLazyPat.hs:5:3: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘~(x, y)’
+ (non-variable lazy pattern aren't linear)
• In the pattern: ~(x, y)
In an equation for ‘f’: f ~(x, y) = (y, x)
diff --git a/testsuite/tests/linear/should_fail/LinearLet6.stderr b/testsuite/tests/linear/should_fail/LinearLet6.stderr
index 545b61162c0320e6c611fb0fe604dca62d2fad97..bb8a9bace8bcd4fb76960220a33276e7a333be95 100644
--- a/testsuite/tests/linear/should_fail/LinearLet6.stderr
+++ b/testsuite/tests/linear/should_fail/LinearLet6.stderr
@@ -15,7 +15,8 @@ LinearLet6.hs:10:3: error: [GHC-18872]
LinearLet6.hs:15:14: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘Just y’
+ (non-variable lazy pattern aren't linear)
• In a pattern binding: (Just y) = x
In the expression: let %1 (Just y) = x in y
In an equation for ‘h’: h x = let %1 (Just y) = x in y
diff --git a/testsuite/tests/linear/should_fail/LinearLet7.stderr b/testsuite/tests/linear/should_fail/LinearLet7.stderr
index 260ca28b7abbd8a82a139a41a4df12a21bbbc216..af01d2658744eea66fa6c0596685bc59a5a8dcb4 100644
--- a/testsuite/tests/linear/should_fail/LinearLet7.stderr
+++ b/testsuite/tests/linear/should_fail/LinearLet7.stderr
@@ -8,6 +8,7 @@ LinearLet7.hs:6:14: error: [GHC-18872]
LinearLet7.hs:6:14: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
+ (non-variable pattern bindings that have been generalised aren't linear)
• In the expression: let %1 g = \ y -> ... in g x
In an equation for ‘f’: f x = let %1 g = ... in g x
diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn.stderr b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
index 965cd086a20e97d5ded0665fb43f0c6d7e8f7bc3..4acf21377e2cf9b6f1ec59e39eba5906e870bfc0 100644
--- a/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
+++ b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
@@ -1,6 +1,7 @@
LinearPatSyn.hs:13:4: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
+ (pattern synonyms aren't linear)
• In the pattern: P y x
In an equation for ‘s’: s (P y x) = (y, x)
diff --git a/testsuite/tests/linear/should_fail/LinearViewPattern.stderr b/testsuite/tests/linear/should_fail/LinearViewPattern.stderr
index cbd3cd95955ab371b51e323004323e232689b661..de6f02169a8d1841496afafbef3298d5442d8c1d 100644
--- a/testsuite/tests/linear/should_fail/LinearViewPattern.stderr
+++ b/testsuite/tests/linear/should_fail/LinearViewPattern.stderr
@@ -1,6 +1,7 @@
LinearViewPattern.hs:11:4: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘not -> True’
+ (view patterns aren't linear)
• In the pattern: not -> True
In an equation for ‘f’: f (not -> True) = True
diff --git a/testsuite/tests/linear/should_fail/T20083.stderr b/testsuite/tests/linear/should_fail/T20083.stderr
index e923aaf2fe32f03595f144d838526616c5e2518a..e2fb5e91ccde0a8fade0db356aeba2798995d6ee 100644
--- a/testsuite/tests/linear/should_fail/T20083.stderr
+++ b/testsuite/tests/linear/should_fail/T20083.stderr
@@ -13,6 +13,6 @@ T20083.hs:6:6: error: [GHC-25897]
T20083.hs:9:5: error: [GHC-18872]
• Couldn't match type ‘Many’ with ‘One’
- arising from a non-linear pattern
+ arising from a non-linear pattern ‘_’
• In the pattern: _
In an equation for ‘ap2’: ap2 _ = ()