diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-01-08 18:42:14 +0100 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-01-26 09:49:54 -0500 |
| commit | e02cd9dd5aa214427f16ebb736e4e1ff088b1b00 (patch) | |
| tree | 83b8f2741695fdcceb817993938a2a1c67360876 | |
| parent | 9030120eeb13c10eb03ff542ce96246a936e5b03 (diff) | |
| download | haskell-e02cd9dd5aa214427f16ebb736e4e1ff088b1b00.tar.gz | |
Fix unsoundness for linear guards (#19120)
(cherry picked from commit 62cac31cd20708d7dd77131e0f822a3eed0d0661)
| -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 c092ec9883..66e28cc3c7 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -383,7 +383,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 313458061d..1983e67ce6 100644 --- a/testsuite/tests/linear/should_fail/all.T +++ b/testsuite/tests/linear/should_fail/all.T @@ -32,3 +32,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, ['']) |