Infer rho-types instead of sigma-types in guard BindStmts and TransStmtswip/T17343

In #17343 we saw that we didn't handle the pattern guard `!_ <-
undefined` correctly: The `undefined` was never evaluated. Indeed,
elaboration failed to insert the invisible type aruments to `undefined`.
So `undefined` was trivially a normal-form and in turn never entered.

The problem is that we used to infer a sigma-type for the RHS of the
guard, the leading qualifiers of which will never be useful in a pattern
match situation. Hence we infer a rho-type now.

Fixes #17343.

5 files changed, 18 insertions, 5 deletions

diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot
index 25650e34fc..efebcdc6e5 100644
--- a/compiler/typecheck/TcExpr.hs-boot
+++ b/compiler/typecheck/TcExpr.hs-boot
@@ -15,11 +15,11 @@ tcMonoExpr, tcMonoExprNC ::
        -> ExpRhoType
        -> TcM (LHsExpr GhcTcId)
 
-tcInferSigma, tcInferSigmaNC ::
+tcInferSigma ::
           LHsExpr GhcRn
        -> TcM (LHsExpr GhcTcId, TcSigmaType)
 
-tcInferRho ::
+tcInferRho, tcInferRhoNC ::
           LHsExpr GhcRn
        -> TcM (LHsExpr GhcTcId, TcRhoType)
 
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index b01776a175..f971da2aa3 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -21,7 +21,7 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
 
 import GhcPrelude
 
-import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho
                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
 import BasicTypes (LexicalFixity(..))
@@ -404,7 +404,7 @@ 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) <- tcInferSigmaNC rhs
+  = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs
                                    -- Stmt has a context already
         ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
                                     pat (mkCheckExpType rhs_ty) $
@@ -478,7 +478,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
              --  passed in to tcStmtsAndThen is never looked at
        ; (stmts', (bndr_ids, by'))
             <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
-               { by' <- traverse tcInferSigma by
+               { by' <- traverse tcInferRho by
                ; bndr_ids <- tcLookupLocalIds bndr_names
                ; return (bndr_ids, by') }
 
diff --git a/testsuite/tests/typecheck/should_compile/T17343.hs b/testsuite/tests/typecheck/should_compile/T17343.hs
new file mode 100644
index 0000000000..e3179b4e23
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T17343.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
+
+h :: ()
+h | !_ <- undefined = ()
+{-# NOINLINE h #-}
+
+-- main is expected to crash
+main = print h
diff --git a/testsuite/tests/typecheck/should_compile/T17343.stderr b/testsuite/tests/typecheck/should_compile/T17343.stderr
new file mode 100644
index 0000000000..044fa41d77
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T17343.stderr
@@ -0,0 +1,4 @@
+T17343: Prelude.undefined
+CallStack (from HasCallStack):
+  error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
+  undefined, called at T17343.hs:4:5 in main:Main
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 7594265db6..c51ff0b36b 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -692,3 +692,4 @@ test('T17067', normal, compile, [''])
 test('T17202', expect_broken(17202), compile, [''])
 test('T15839a', normal, compile, [''])
 test('T15839b', normal, compile, [''])
+test('T17343', exit_code(1), compile_and_run, [''])