[commit: ghc] ghc-8.2: Fix #13929 by adding another levity polymorphism check (0c932d4)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/0c932d4c854ccee953bcc305ac7642e59696b762/ghc

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

commit 0c932d4c854ccee953bcc305ac7642e59696b762
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
    
    (cherry picked from commit fa626f3b1c1140a1f10bba60fdde10f767863f70)


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

0c932d4c854ccee953bcc305ac7642e59696b762
 compiler/deSugar/DsExpr.hs                         |  9 +++---
 testsuite/tests/typecheck/should_fail/T13929.hs    | 32 ++++++++++++++++++++++
 .../tests/typecheck/should_fail/T13929.stderr      | 12 ++++++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 4 files changed, 49 insertions(+), 5 deletions(-)

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index bacf950..3cbc917 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -372,14 +372,13 @@ dsExpr (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) }
 
 dsExpr (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 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 65f507b..9f9752a 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -437,4 +437,5 @@ test('T13677', normal, compile_fail, [''])
 test('T11963', normal, compile_fail, [''])
 test('T14000', normal, compile_fail, [''])
 test('T11672', normal, compile_fail, [''])
+test('T13929', normal, compile_fail, [''])