[commit: ghc] wip/rae: Fix #13929 by adding another levity polymorphism check (63b35af)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/63b35af16b1e8d216ec1ffc480c333829b015292/ghc

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

commit 63b35af16b1e8d216ec1ffc480c333829b015292
Author: Richard Eisenberg <rae at cs.brynmawr.edu>
Date:   Wed Aug 16 11:35:26 2017 -0400

    Fix #13929 by adding another levity polymorphism check
    
    test case: typecheck/should_fail/T13929


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

63b35af16b1e8d216ec1ffc480c333829b015292
 compiler/deSugar/DsExpr.hs                         |  9 +++---
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 testsuite/tests/typecheck/should_fail/T13929.hs    | 32 ++++++++++++++++++++++
 .../tests/typecheck/should_fail/T13929.stderr      | 12 ++++++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 5 files changed, 50 insertions(+), 5 deletions(-)

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 048d558..853c42d 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -368,14 +368,13 @@ ds_expr _ (ExplicitTuple tup_args boxity)
              go (lam_vars, args) (L _ (Present expr))
                     -- Expressions that are present don't generate
                     -- lambdas, just arguments.
-               = do { core_expr <- dsLExpr expr
+               = do { core_expr <- dsLExprNoLP expr
                     ; return (lam_vars, core_expr : args) }
 
-       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
+       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
-
-       ; return $ mkCoreLams lam_vars $
-                  mkCoreTupBoxity boxity args }
+                      (\(lam_vars, args) -> mkCoreLams lam_vars $
+                                            mkCoreTupBoxity boxity args) }
 
 ds_expr _ (ExplicitSum alt arity expr types)
   = do { core_expr <- dsLExpr expr
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index f522b74..bb764db 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -571,3 +571,4 @@ test('T13881', normal, compile, [''])
 test('T13915a', normal, multimod_compile, ['T13915a', '-v0'])
 test('T13915b', normal, compile, [''])
 test('T13984', normal, compile, [''])
+test('T13643', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T13929.hs b/testsuite/tests/typecheck/should_fail/T13929.hs
new file mode 100644
index 0000000..f0a026d
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13929.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Main where
+
+import GHC.Exts
+import Data.Kind
+import GHC.Generics
+
+class GUnbox (f :: Type -> Type) (r :: RuntimeRep) where
+    type GUnboxed f r :: TYPE r
+    gunbox :: f p -> GUnboxed f r
+
+instance (GUnbox f rf, GUnbox g rg) => GUnbox (f :*: g) ('TupleRep '[rf, rg]) where
+    type GUnboxed (f :*: g) ('TupleRep '[rf, rg]) = (# GUnboxed f rf, GUnboxed g rg #)
+    -- if I remove implementation of `gunbox` it compiles successfully
+    gunbox (x :*: y) = (# gunbox x, gunbox y #)
+
+main :: IO ()
+main = pure ()
diff --git a/testsuite/tests/typecheck/should_fail/T13929.stderr b/testsuite/tests/typecheck/should_fail/T13929.stderr
new file mode 100644
index 0000000..3ddf5b3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13929.stderr
@@ -0,0 +1,12 @@
+
+T13929.hs:29:27: error:
+    A levity-polymorphic type is not allowed here:
+      Type: GUnboxed f rf
+      Kind: TYPE rf
+    In the type of expression: gunbox x
+
+T13929.hs:29:37: error:
+    A levity-polymorphic type is not allowed here:
+      Type: GUnboxed g rg
+      Kind: TYPE rg
+    In the type of expression: gunbox y
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index d07cb11..67cdc5f 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -456,3 +456,4 @@ test('T11963', normal, compile_fail, [''])
 test('T14000', normal, compile_fail, [''])
 test('T14055', normal, compile_fail, [''])
 test('T13909', normal, compile_fail, [''])
+test('T13929', normal, compile_fail, [''])