diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-01-08 18:42:14 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-17 05:54:19 -0500 |
| commit | 62cac31cd20708d7dd77131e0f822a3eed0d0661 (patch) | |
| tree | d0b5733950a039bea3bef1b38a013c71d05e3c93 | |
| parent | 66414bdf40534f07ac730e25f78e591994d2c1e4 (diff) | |
| download | haskell-62cac31cd20708d7dd77131e0f822a3eed0d0661.tar.gz | |
Fix unsoundness for linear guards (#19120)
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/T19120.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/T19120.stderr | 5 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/all.T | 1 |
4 files changed, 18 insertions, 1 deletions
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 1b9e0185f3..3d20305c88 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -395,7 +395,8 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcCheckMonoExpr guard boolTy + = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy + -- Scale the guard to Many (see #19120 and #19193) ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } diff --git a/testsuite/tests/linear/should_fail/T19120.hs b/testsuite/tests/linear/should_fail/T19120.hs new file mode 100644 index 0000000000..9400e5d2a6 --- /dev/null +++ b/testsuite/tests/linear/should_fail/T19120.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +module T19120 where + +notL :: Bool %1 -> Bool +notL True = False +notL False = True + +z :: Bool %1 -> Bool +z x | notL x = True +z x | otherwise = notL x diff --git a/testsuite/tests/linear/should_fail/T19120.stderr b/testsuite/tests/linear/should_fail/T19120.stderr new file mode 100644 index 0000000000..5926c50047 --- /dev/null +++ b/testsuite/tests/linear/should_fail/T19120.stderr @@ -0,0 +1,5 @@ + +T19120.hs:9:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘z’: z x | notL x = True diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T index 60bf3c4337..3dbf154705 100644 --- a/testsuite/tests/linear/should_fail/all.T +++ b/testsuite/tests/linear/should_fail/all.T @@ -34,3 +34,4 @@ test('LinearFFI', normal, compile_fail, ['']) test('LinearTHFail', normal, compile_fail, ['']) test('T18888', normal, compile_fail, ['']) test('T18888_datakinds', normal, compile_fail, ['']) +test('T19120', normal, compile_fail, ['']) |