summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArnaud Spiwack <arnaud.spiwack@tweag.io>2020-09-23 12:20:46 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-09-25 21:13:58 -0400
commit2707c4eae4cf99e6da2709e128f560d91e468357 (patch)
tree729acd98bb114b7e799995a4d7bdc6b0fb7f1e59
parent516062366ed1957e499f27dfc6b685a073a18400 (diff)
downloadhaskell-2707c4eae4cf99e6da2709e128f560d91e468357.tar.gz
Pattern guards BindStmt always use multiplicity Many
Fixes #18439 . The rhs of the pattern guard was consumed with multiplicity one, while the pattern assumed it was Many. We use Many everywhere instead. This is behaviour consistent with that of `case` expression. See #18738.
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs9
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs7
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr5
-rw-r--r--testsuite/tests/linear/should_fail/all.T1
4 files changed, 21 insertions, 1 deletions
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 30fe0cad44..38e400419a 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -397,7 +397,14 @@ tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
+ = do { -- The Many on the next line and the unrestricted on the line after
+ -- are linked. These must be the same multiplicity. Consider
+ -- x <- rhs -> u
+ --
+ -- The multiplicity of x in u must be the same as the multiplicity at
+ -- which the rhs has been consumed. When solving #18738, we want these
+ -- two multiplicity to still be the same.
+ (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs
-- Stmt has a context already
; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (unrestricted rhs_ty) $
diff --git a/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs b/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs
new file mode 100644
index 0000000000..be837fd80b
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearPatternGuardWildcard where
+
+-- See #18439
+
+unsafeConsume :: a #-> ()
+unsafeConsume x | _ <- x = ()
diff --git a/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr b/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr
new file mode 100644
index 0000000000..466ad41862
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr
@@ -0,0 +1,5 @@
+
+LinearPatternGuardWildcard.hs:7:15: error:
+ • Couldn't match type ‘'Many’ with ‘'One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘unsafeConsume’: unsafeConsume x | _ <- x = ()
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index 67906053dc..941966673c 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -27,3 +27,4 @@ test('LinearPolyType', expect_broken([436, broken_multiplicity_syntax]), compile
test('LinearBottomMult', normal, compile_fail, [''])
test('LinearSequenceExpr', normal, compile_fail, [''])
test('LinearIf', normal, compile_fail, [''])
+test('LinearPatternGuardWildcard', normal, compile_fail, [''])