[commit: ghc] master: Correct checkStrictBinds for generalised type (806d823)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/806d823e757c73f77f03fdf2d1eba6a83b1e32e6/ghc

>---------------------------------------------------------------

commit 806d823e757c73f77f03fdf2d1eba6a83b1e32e6
Author: archblob <fcsernik at gmail.com>
Date:   Tue Aug 19 06:51:38 2014 -0500

    Correct checkStrictBinds for generalised type
    
    See Trac #9140.
    
    Auditors: simonpj
    
    Signed-off-by: Austin Seipp <austin at well-typed.com>


>---------------------------------------------------------------

806d823e757c73f77f03fdf2d1eba6a83b1e32e6
 compiler/typecheck/TcBinds.lhs            |  4 ++--
 testsuite/tests/ghci/scripts/T9140.script |  5 +++++
 testsuite/tests/ghci/scripts/T9140.stdout | 14 ++++++++++++++
 testsuite/tests/ghci/scripts/all.T        |  1 +
 4 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 34db200..14a5704 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -1454,8 +1454,8 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
     any_strict_pat     = any (isStrictHsBind   . unLoc) orig_binds
     any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
 
-    is_unlifted id = case tcSplitForAllTys (idType id) of
-                       (_, rho) -> isUnLiftedType rho
+    is_unlifted id = case tcSplitSigmaTy (idType id) of
+                       (_, _, rho) -> isUnLiftedType rho
 
     is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
                      = null tvs && null evs
diff --git a/testsuite/tests/ghci/scripts/T9140.script b/testsuite/tests/ghci/scripts/T9140.script
new file mode 100644
index 0000000..833ea87
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9140.script
@@ -0,0 +1,5 @@
+:set -XUnboxedTuples -XBangPatterns
+let a = (# 1 #)
+let a = (# 1, 3 #)
+:set -XBangPatterns
+let !a = (# 1, 3 #)
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
new file mode 100644
index 0000000..a5cb42f
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -0,0 +1,14 @@
+
+<interactive>:3:5:
+    You can't mix polymorphic and unlifted bindings
+      a = (# 1 #)
+      Probable fix: use a bang pattern
+
+<interactive>:4:5:
+    You can't mix polymorphic and unlifted bindings
+      a = (# 1, 3 #)
+      Probable fix: use a bang pattern
+
+Top level:
+    GHCi can't bind a variable of unlifted type:
+      a :: (# Integer, Integer #)
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index d5a313a..f02a3c0 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -177,3 +177,4 @@ test('T8959', normal, ghci_script, ['T8959.script'])
 test('T8959b', expect_broken(8959), ghci_script, ['T8959b.script'])
 test('T9181', normal, ghci_script, ['T9181.script'])
 test('T9086b', normal, ghci_script, ['T9086b.script'])
+test('T9140', combined_output, ghci_script, ['T9140.script'])