From dec6d8d3d623dc982e2b22d44a1e2bab62794f38 Mon Sep 17 00:00:00 2001
From: Arnaud Spiwack <arnaud.spiwack@tweag.io>
Date: Fri, 19 Jan 2024 15:45:25 +0100
Subject: [PATCH] Improve error messages coming from non-linear patterns
This enriched the `CtOrigin` for non-linear patterns to include data
of the pattern that created the constraint (which can be quite useful
if it occurs nested in a pattern) as well as an explanation why the
pattern is non-restricted in (at least in some cases).
---
compiler/GHC/Tc/Errors.hs | 2 +-
compiler/GHC/Tc/Gen/Bind.hs | 2 +-
compiler/GHC/Tc/Gen/Pat.hs | 22 ++++++++---------
compiler/GHC/Tc/Types/Origin.hs | 24 +++++++++++++++----
.../tests/linear/should_fail/Linear9.stderr | 8 +++----
.../linear/should_fail/LinearAsPat.stderr | 2 +-
.../linear/should_fail/LinearLazyPat.stderr | 3 ++-
.../linear/should_fail/LinearLet6.stderr | 3 ++-
.../linear/should_fail/LinearLet7.stderr | 3 ++-
.../linear/should_fail/LinearPatSyn.stderr | 3 ++-
.../should_fail/LinearViewPattern.stderr | 3 ++-
.../tests/linear/should_fail/T20083.stderr | 2 +-
12 files changed, 49 insertions(+), 28 deletions(-)
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 2586559d11cc..857e02e37344 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 68f1edfbd1e3..c9018253950e 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 9ec72d27ac1f..99ffe6561bf2 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 82e60727aa91..aea97da224eb 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 87092b13b72e..14e943cf2711 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 987993d8970f..0aea88e4cd35 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 82fb02725b4b..a53bdfe4c0b7 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 545b61162c03..bb8a9bace8bc 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 260ca28b7abb..af01d2658744 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 965cd086a20e..4acf21377e2c 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 cbd3cd95955a..de6f02169a8d 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 e923aaf2fe32..e2fb5e91ccde 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 _ = ()
--
GitLab