Fix #13929 by adding another levity polymorphism check
authorRichard Eisenberg <rae@cs.brynmawr.edu>
Wed, 16 Aug 2017 15:35:26 +0000 (11:35 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 14 Sep 2017 18:28:24 +0000 (14:28 -0400)
test case: typecheck/should_fail/T13929

compiler/deSugar/DsExpr.hs
testsuite/tests/typecheck/should_fail/T13929.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13929.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 2d86b84..b8ed3c5 100644 (file)
@@ -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 (file)
index 0000000..f0a026d
--- /dev/null
@@ -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 (file)
index 0000000..3ddf5b3
--- /dev/null
@@ -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
index 230e5f4..fe71e37 100644 (file)
@@ -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, [''])