[commit: ghc] master: desugar: Catch levity polymorphism in unboxed sum expressions (018c40f)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/018c40fb1bb27853d0cefa5b90a44ce13e91a856/ghc

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

commit 018c40fb1bb27853d0cefa5b90a44ce13e91a856
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Tue Sep 26 14:52:26 2017 -0400

    desugar: Catch levity polymorphism in unboxed sum expressions
    
    Fixes #13929.


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

018c40fb1bb27853d0cefa5b90a44ce13e91a856
 compiler/deSugar/DsExpr.hs                          | 10 +++++-----
 testsuite/tests/typecheck/should_fail/T13929.stderr | 12 ++++++++++++
 testsuite/tests/typecheck/should_fail/all.T         |  2 +-
 3 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 1ed45fc..b2b98f8 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -379,11 +379,11 @@ ds_expr _ (ExplicitTuple tup_args boxity)
                                             mkCoreTupBoxity boxity args) }
 
 ds_expr _ (ExplicitSum alt arity expr types)
-  = do { core_expr <- dsLExpr expr
-       ; return $ mkCoreConApps (sumDataCon alt arity)
-                                (map (Type . getRuntimeRep) types ++
-                                 map Type types ++
-                                 [core_expr]) }
+  = do { dsWhenNoErrs (dsLExprNoLP expr)
+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)
+                                     (map (Type . getRuntimeRep) types ++
+                                      map Type types ++
+                                      [core_expr]) ) }
 
 ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
     dflags <- getDynFlags
diff --git a/testsuite/tests/typecheck/should_fail/T13929.stderr b/testsuite/tests/typecheck/should_fail/T13929.stderr
index 3ddf5b3..d1e1f63 100644
--- a/testsuite/tests/typecheck/should_fail/T13929.stderr
+++ b/testsuite/tests/typecheck/should_fail/T13929.stderr
@@ -10,3 +10,15 @@ T13929.hs:29:37: error:
       Type: GUnboxed g rg
       Kind: TYPE rg
     In the type of expression: gunbox y
+
+T13929.hs:33:24:
+    A levity-polymorphic type is not allowed here:
+      Type: GUnboxed f rf
+      Kind: TYPE rf
+    In the type of expression: gunbox l
+
+T13929.hs:34:26:
+    A levity-polymorphic type is not allowed here:
+      Type: GUnboxed g rg
+      Kind: TYPE rg
+    In the type of expression: gunbox r
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 5079397..fe71e37 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -456,5 +456,5 @@ test('T11963', normal, compile_fail, [''])
 test('T14000', normal, compile_fail, [''])
 test('T14055', normal, compile_fail, [''])
 test('T13909', normal, compile_fail, [''])
-test('T13929', expect_broken(13929), compile_fail, [''])
+test('T13929', normal, compile_fail, [''])
 test('T14232', normal, compile_fail, [''])