Fix #13929 by adding another levity polymorphism check

test case: typecheck/should_fail/T13929

4 files changed, 49 insertions, 5 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 2d86b8438a..b8ed3c5fbf 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_fail/T13929.hs b/testsuite/tests/typecheck/should_fail/T13929.hs
new file mode 100644
index 0000000000..f0a026d27e
--- /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 0000000000..3ddf5b38c0
--- /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 230e5f478d..fe71e3715d 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -456,4 +456,5 @@ 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, [''])
 test('T14232', normal, compile_fail, [''])