Infer rho-types instead of sigma-types in guard BindStmts and TransStmts
authorSebastian Graf <sgraf1337@gmail.com>
Tue, 15 Oct 2019 12:10:14 +0000 (13:10 +0100)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Wed, 16 Oct 2019 11:06:20 +0000 (07:06 -0400)
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.

compiler/typecheck/TcExpr.hs-boot
compiler/typecheck/TcMatches.hs
testsuite/tests/typecheck/should_compile/T17343.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T17343.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 25650e3..efebcdc 100644 (file)
@@ -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)
 
index b01776a..f971da2 100644 (file)
@@ -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 (file)
index 0000000..e3179b4
--- /dev/null
@@ -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 (file)
index 0000000..044fa41
--- /dev/null
@@ -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
index 7594265..c51ff0b 100644 (file)
@@ -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, [''])