summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
authorRichard Eisenberg <rae@cs.brynmawr.edu>2016-12-14 21:37:43 -0500
committerRichard Eisenberg <rae@cs.brynmawr.edu>2017-01-19 10:31:52 -0500
commite7985ed23ddc68b6a2e4af753578dc1d9e8ab4c9 (patch)
treeba8c4016e218710f8165db92d4b4c10e5559245a /testsuite
parent38374caa9d6e1373d1b9d335d0f99f3664931fd9 (diff)
downloadhaskell-e7985ed23ddc68b6a2e4af753578dc1d9e8ab4c9.tar.gz
Update levity polymorphism
This commit implements the proposal in https://github.com/ghc-proposals/ghc-proposals/pull/29 and https://github.com/ghc-proposals/ghc-proposals/pull/35. Here are some of the pieces of that proposal: * Some of RuntimeRep's constructors have been shortened. * TupleRep and SumRep are now parameterized over a list of RuntimeReps. * This means that two types with the same kind surely have the same representation. Previously, all unboxed tuples had the same kind, and thus the fact above was false. * RepType.typePrimRep and friends now return a *list* of PrimReps. These functions can now work successfully on unboxed tuples. This change is necessary because we allow abstraction over unboxed tuple types and so cannot always handle unboxed tuples specially as we did before. * We sometimes have to create an Id from a PrimRep. I thus split PtrRep * into LiftedRep and UnliftedRep, so that the created Ids have the right strictness. * The RepType.RepType type was removed, as it didn't seem to help with * much. * The RepType.repType function is also removed, in favor of typePrimRep. * I have waffled a good deal on whether or not to keep VoidRep in TyCon.PrimRep. In the end, I decided to keep it there. PrimRep is *not* represented in RuntimeRep, and typePrimRep will never return a list including VoidRep. But it's handy to have in, e.g., ByteCodeGen and friends. I can imagine another design choice where we have a PrimRepV type that is PrimRep with an extra constructor. That seemed to be a heavier design, though, and I'm not sure what the benefit would be. * The last, unused vestiges of # (unliftedTypeKind) have been removed. * There were several pretty-printing bugs that this change exposed; * these are fixed. * We previously checked for levity polymorphism in the types of binders. * But we also must exclude levity polymorphism in function arguments. This is hard to check for, requiring a good deal of care in the desugarer. See Note [Levity polymorphism checking] in DsMonad. * In order to efficiently check for levity polymorphism in functions, it * was necessary to add a new bit of IdInfo. See Note [Levity info] in IdInfo. * It is now safe for unlifted types to be unsaturated in Core. Core Lint * is updated accordingly. * We can only know strictness after zonking, so several checks around * strictness in the type-checker (checkStrictBinds, the check for unlifted variables under a ~ pattern) have been moved to the desugarer. * Along the way, I improved the treatment of unlifted vs. banged * bindings. See Note [Strict binds checks] in DsBinds and #13075. * Now that we print type-checked source, we must be careful to print * ConLikes correctly. This is facilitated by a new HsConLikeOut constructor to HsExpr. Particularly troublesome are unlifted pattern synonyms that get an extra void# argument. * Includes a submodule update for haddock, getting rid of #. * New testcases: typecheck/should_fail/StrictBinds typecheck/should_fail/T12973 typecheck/should_run/StrictPats typecheck/should_run/T12809 typecheck/should_fail/T13105 patsyn/should_fail/UnliftedPSBind typecheck/should_fail/LevPolyBounded typecheck/should_compile/T12987 typecheck/should_compile/T11736 * Fixed tickets: #12809 #12973 #11736 #13075 #12987 * This also adds a test case for #13105. This test case is * "compile_fail" and succeeds, because I want the testsuite to monitor the error message. When #13105 is fixed, the test case will compile cleanly.
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/deSugar/should_compile/T10662.stderr2
-rw-r--r--testsuite/tests/dependent/should_compile/RaeJobTalk.hs6
-rw-r--r--testsuite/tests/dependent/should_fail/T11473.stderr2
-rw-r--r--testsuite/tests/deriving/should_fail/T12512.hs7
-rw-r--r--testsuite/tests/deriving/should_fail/T12512.stderr4
-rw-r--r--testsuite/tests/ghci/scripts/GhciKinds.stdout6
-rw-r--r--testsuite/tests/ghci/scripts/T9140.stdout10
-rw-r--r--testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs12
-rw-r--r--testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr8
-rw-r--r--testsuite/tests/patsyn/should_fail/all.T1
-rw-r--r--testsuite/tests/patsyn/should_fail/unboxed-bind.hs1
-rw-r--r--testsuite/tests/patsyn/should_fail/unboxed-bind.stderr10
-rw-r--r--testsuite/tests/quasiquotation/T7918.stdout8
-rw-r--r--testsuite/tests/simplCore/should_compile/T9400.stderr2
-rw-r--r--testsuite/tests/simplCore/should_compile/spec-inline.stderr2
-rw-r--r--testsuite/tests/th/T12403.stdout6
-rw-r--r--testsuite/tests/th/T12478_1.stdout2
-rw-r--r--testsuite/tests/th/T5358.stderr16
-rw-r--r--testsuite/tests/th/T5976.stderr4
-rw-r--r--testsuite/tests/th/T8987.stderr6
-rw-r--r--testsuite/tests/typecheck/should_compile/T11723.hs7
-rw-r--r--testsuite/tests/typecheck/should_compile/T11736.hs8
-rw-r--r--testsuite/tests/typecheck/should_compile/T12987.hs7
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T3
-rw-r--r--testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs10
-rw-r--r--testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/LevPolyBounded.hs11
-rw-r--r--testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr5
-rw-r--r--testsuite/tests/typecheck/should_fail/StrictBinds.hs9
-rw-r--r--testsuite/tests/typecheck/should_fail/StrictBinds.stderr5
-rw-r--r--testsuite/tests/typecheck/should_fail/T11723.hs8
-rw-r--r--testsuite/tests/typecheck/should_fail/T11723.stderr7
-rw-r--r--testsuite/tests/typecheck/should_fail/T11724.stderr2
-rw-r--r--testsuite/tests/typecheck/should_fail/T12973.hs15
-rw-r--r--testsuite/tests/typecheck/should_fail/T12973.stderr12
-rw-r--r--testsuite/tests/typecheck/should_fail/T13105.hs23
-rw-r--r--testsuite/tests/typecheck/should_fail/T13105.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/T2806.hs2
-rw-r--r--testsuite/tests/typecheck/should_fail/T2806.stderr10
-rw-r--r--testsuite/tests/typecheck/should_fail/T6078.stderr10
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T10
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail203.hs1
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail203.stderr66
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail203a.stderr9
-rw-r--r--testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs32
-rw-r--r--testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout4
-rw-r--r--testsuite/tests/typecheck/should_run/KindInvariant.stderr2
-rw-r--r--testsuite/tests/typecheck/should_run/StrictPats.hs122
-rw-r--r--testsuite/tests/typecheck/should_run/StrictPats.stdout19
-rw-r--r--testsuite/tests/typecheck/should_run/T12809.hs44
-rw-r--r--testsuite/tests/typecheck/should_run/T12809.stdout4
-rw-r--r--testsuite/tests/typecheck/should_run/TypeOf.hs4
-rw-r--r--testsuite/tests/typecheck/should_run/TypeOf.stdout2
-rw-r--r--testsuite/tests/typecheck/should_run/TypeRep.hs4
-rw-r--r--testsuite/tests/typecheck/should_run/TypeRep.stdout2
-rwxr-xr-xtestsuite/tests/typecheck/should_run/all.T3
-rw-r--r--testsuite/tests/unboxedsums/T12711.stdout3
-rw-r--r--testsuite/tests/unboxedsums/UbxSumLevPoly.hs12
-rw-r--r--testsuite/tests/unboxedsums/all.T4
-rw-r--r--testsuite/tests/unboxedsums/sum_rr.hs4
-rw-r--r--testsuite/tests/unboxedsums/sum_rr.stderr7
-rw-r--r--testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs2
62 files changed, 487 insertions, 154 deletions
diff --git a/testsuite/tests/deSugar/should_compile/T10662.stderr b/testsuite/tests/deSugar/should_compile/T10662.stderr
index d81891619c..f27fc977b6 100644
--- a/testsuite/tests/deSugar/should_compile/T10662.stderr
+++ b/testsuite/tests/deSugar/should_compile/T10662.stderr
@@ -2,4 +2,4 @@
T10662.hs:3:3: warning: [-Wunused-do-bind (in -Wall)]
A do-notation statement discarded a result of type ‘[Char]’
Suppress this warning by saying
- ‘_ <- ($) return let a = "hello" in a’
+ ‘_ <- return $ let a = "hello" in a’
diff --git a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
index 2f0edf8593..e5c2002e0c 100644
--- a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
+++ b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
@@ -82,7 +82,7 @@ data TyCon (a :: k) where
Arrow :: TyCon (->)
TYPE :: TyCon TYPE
RuntimeRep :: TyCon RuntimeRep
- PtrRepLifted' :: TyCon 'PtrRepLifted
+ LiftedRep' :: TyCon 'LiftedRep
-- If extending, add to eqTyCon too
eqTyCon :: TyCon a -> TyCon b -> Maybe (a :~~: b)
@@ -94,7 +94,7 @@ eqTyCon Maybe Maybe = Just HRefl
eqTyCon Arrow Arrow = Just HRefl
eqTyCon TYPE TYPE = Just HRefl
eqTyCon RuntimeRep RuntimeRep = Just HRefl
-eqTyCon PtrRepLifted' PtrRepLifted' = Just HRefl
+eqTyCon LiftedRep' LiftedRep' = Just HRefl
eqTyCon _ _ = Nothing
-- Check whether or not a type is really a plain old tycon;
@@ -212,7 +212,7 @@ instance TyConAble [] where tyCon = List
instance TyConAble Maybe where tyCon = Maybe
instance TyConAble (->) where tyCon = Arrow
instance TyConAble TYPE where tyCon = TYPE
-instance TyConAble 'PtrRepLifted where tyCon = PtrRepLifted'
+instance TyConAble 'LiftedRep where tyCon = LiftedRep'
instance TyConAble RuntimeRep where tyCon = RuntimeRep
-- Can't just define Typeable the way we want, because the instances
diff --git a/testsuite/tests/dependent/should_fail/T11473.stderr b/testsuite/tests/dependent/should_fail/T11473.stderr
index 431c2dff92..3252452eb2 100644
--- a/testsuite/tests/dependent/should_fail/T11473.stderr
+++ b/testsuite/tests/dependent/should_fail/T11473.stderr
@@ -1,6 +1,6 @@
T11473.hs:19:7: error:
- A representation-polymorphic type is not allowed here:
+ A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE r
In the type of binder ‘x’
diff --git a/testsuite/tests/deriving/should_fail/T12512.hs b/testsuite/tests/deriving/should_fail/T12512.hs
index 87c3d668df..4d4e52c06c 100644
--- a/testsuite/tests/deriving/should_fail/T12512.hs
+++ b/testsuite/tests/deriving/should_fail/T12512.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TypeInType #-}
module T12512 where
import GHC.Exts
-class Wat1 (a :: TYPE 'UnboxedTupleRep)
+class Wat1 (a :: TYPE ('TupleRep ['LiftedRep, 'LiftedRep]))
deriving instance Wat1 (# a, b #)
-class Wat2 (a :: TYPE 'UnboxedSumRep)
+class Wat2 (a :: TYPE ('SumRep ['LiftedRep, 'LiftedRep]))
deriving instance Wat2 (# a | b #)
diff --git a/testsuite/tests/deriving/should_fail/T12512.stderr b/testsuite/tests/deriving/should_fail/T12512.stderr
index 48f0eae205..a62cda6b99 100644
--- a/testsuite/tests/deriving/should_fail/T12512.stderr
+++ b/testsuite/tests/deriving/should_fail/T12512.stderr
@@ -1,10 +1,10 @@
-T12512.hs:11:1: error:
+T12512.hs:10:1: error:
• Can't make a derived instance of ‘Wat1 (# a, b #)’:
The last argument of the instance cannot be an unboxed tuple
• In the stand-alone deriving instance for ‘Wat1 (# a, b #)’
-T12512.hs:14:1: error:
+T12512.hs:13:1: error:
• Can't make a derived instance of ‘Wat2 (# a | b #)’:
The last argument of the instance cannot be an unboxed sum
• In the stand-alone deriving instance for ‘Wat2 (# a | b #)’
diff --git a/testsuite/tests/ghci/scripts/GhciKinds.stdout b/testsuite/tests/ghci/scripts/GhciKinds.stdout
index 3556e621a4..5431bbc17d 100644
--- a/testsuite/tests/ghci/scripts/GhciKinds.stdout
+++ b/testsuite/tests/ghci/scripts/GhciKinds.stdout
@@ -10,4 +10,8 @@ F (Maybe Bool) :: *
forall a. F (Maybe a) :: *
= Char
$(unboxedTupleT 2) :: forall (k0 :: RuntimeRep) (k1 :: RuntimeRep).
- TYPE k0 -> TYPE k1 -> TYPE 'UnboxedTupleRep
+ TYPE k0
+ -> TYPE k1
+ -> TYPE
+ ('TupleRep
+ ((':) RuntimeRep k0 ((':) RuntimeRep k1 ('[] RuntimeRep))))
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
index 6456067f59..85406d04b6 100644
--- a/testsuite/tests/ghci/scripts/T9140.stdout
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -1,13 +1,11 @@
<interactive>:2:5: error:
- You can't mix polymorphic and unlifted bindings
- a = (# 1 #)
- Probable fix: add a type signature
+ You can't mix polymorphic and unlifted bindings: a = (# 1 #)
+ Probable fix: add a type signature
<interactive>:3:5: error:
- You can't mix polymorphic and unlifted bindings
- a = (# 1, 3 #)
- Probable fix: add a type signature
+ You can't mix polymorphic and unlifted bindings: a = (# 1, 3 #)
+ Probable fix: add a type signature
<interactive>:1:1: error:
GHCi can't bind a variable of unlifted type:
diff --git a/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs
new file mode 100644
index 0000000000..9cb38ed404
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.hs
@@ -0,0 +1,12 @@
+
+-- This is testing the printing of the builder really.
+{-# LANGUAGE MagicHash, PatternSynonyms #-}
+{-# OPTIONS_GHC -Werror -Wunbanged-strict-patterns #-}
+module UnliftedPSBind where
+
+import GHC.Exts
+
+pattern P x = I# x
+
+x = ()
+ where P x = P 4#
diff --git a/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr
new file mode 100644
index 0000000000..6b6b97710e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/UnliftedPSBind.stderr
@@ -0,0 +1,8 @@
+
+UnliftedPSBind.hs:12:9: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
+ P x = P 4#
+
+<no location info>: error:
+Failing due to -Werror.
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index cb23b3fb2a..50a3eea6c1 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -33,3 +33,4 @@ test('T11265', normal, compile_fail, [''])
test('T11667', normal, compile_fail, [''])
test('T12165', normal, compile_fail, [''])
test('T12819', normal, compile_fail, [''])
+test('UnliftedPSBind', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.hs b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs
index ef1b070d49..6be73839f2 100644
--- a/testsuite/tests/patsyn/should_fail/unboxed-bind.hs
+++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PatternSynonyms, MagicHash #-}
+{-# OPTIONS_GHC -Wunbanged-strict-patterns -Werror=unbanged-strict-patterns #-}
module ShouldFail where
import GHC.Base
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr
index 17ca7afd3b..8f20f91be9 100644
--- a/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr
+++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr
@@ -1,6 +1,8 @@
-unboxed-bind.hs:10:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+unboxed-bind.hs:11:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
P arg = x
- In the expression: let P arg = x in arg
- In an equation for ‘f’: f x = let P arg = x in arg
+
+<no location info>: error:
+Failing due to -Werror.
diff --git a/testsuite/tests/quasiquotation/T7918.stdout b/testsuite/tests/quasiquotation/T7918.stdout
index 4dff68d1ce..96482371a2 100644
--- a/testsuite/tests/quasiquotation/T7918.stdout
+++ b/testsuite/tests/quasiquotation/T7918.stdout
@@ -1,10 +1,5 @@
-(True, T7918B.hs:6:11-14)
(id, T7918B.hs:7:11-14)
-(True, T7918B.hs:7:11-14)
-(True, T7918B.hs:8:11-14)
(||, T7918B.hs:8:11-14)
-(False, T7918B.hs:8:11-14)
-(False, T7918B.hs:9:11-14)
(undefined, T7918B.hs:11:7-15)
(Bool, T7918B.hs:11:24-27)
(undefined, T7918B.hs:12:7-15)
@@ -25,6 +20,3 @@
(undefined, T7918B.hs:18:16-24)
(y, T7918B.hs:19:9-12)
(undefined, T7918B.hs:19:16-24)
-(Module, <no location info>)
-(TrNameS, <no location info>)
-(TrNameS, <no location info>)
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr
index d4b7898d83..bab1751a86 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.stderr
+++ b/testsuite/tests/simplCore/should_compile/T9400.stderr
@@ -46,7 +46,7 @@ main =
@ ()
(putStrLn (unpackCString# "efg"#))
(Control.Exception.Base.patError
- @ 'PtrRepLifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#))))
+ @ 'LiftedRep @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#))))
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 732265a8f6..e7fc531a43 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -35,7 +35,7 @@ Roman.foo3 :: Int
[GblId, Str=x]
Roman.foo3 =
Control.Exception.Base.patError
- @ 'GHC.Types.PtrRepLifted
+ @ 'GHC.Types.LiftedRep
@ Int
"spec-inline.hs:(19,5)-(29,25)|function go"#
diff --git a/testsuite/tests/th/T12403.stdout b/testsuite/tests/th/T12403.stdout
index 9b75e8b272..24e222a732 100644
--- a/testsuite/tests/th/T12403.stdout
+++ b/testsuite/tests/th/T12403.stdout
@@ -1 +1,5 @@
-data Main.T = Main.T ((# , #) GHC.Types.Int GHC.Types.Int)
+data Main.T
+ = Main.T ((# , #) GHC.Types.Int
+ GHC.Types.Int :: GHC.Prim.TYPE (GHC.Types.TupleRep (GHC.Types.: GHC.Types.LiftedRep
+ (GHC.Types.: GHC.Types.LiftedRep
+ GHC.Types.[]))))
diff --git a/testsuite/tests/th/T12478_1.stdout b/testsuite/tests/th/T12478_1.stdout
index 8437f925d5..f94db5992d 100644
--- a/testsuite/tests/th/T12478_1.stdout
+++ b/testsuite/tests/th/T12478_1.stdout
@@ -1 +1 @@
-TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] [])
+TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,SigT (AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char)) (AppT (ConT GHC.Prim.TYPE) (AppT (ConT GHC.Types.SumRep) (AppT (AppT (ConT GHC.Types.:) (ConT GHC.Types.LiftedRep)) (AppT (AppT (ConT GHC.Types.:) (ConT GHC.Types.LiftedRep)) (ConT GHC.Types.[]))))))]] [])
diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr
index d9485cebb7..4bfc53a78e 100644
--- a/testsuite/tests/th/T5358.stderr
+++ b/testsuite/tests/th/T5358.stderr
@@ -1,11 +1,11 @@
T5358.hs:14:12: error:
- Exception when trying to run compile-time code:
- runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool
-CallStack (from ImplicitParams):
+ • Exception when trying to run compile-time code:
+ runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool
+CallStack (from HasCallStack):
error, called at T5358.hs:15:18 in main:T5358
- Code: do VarI _ t _ <- reify (mkName "prop_x1")
- ($) error ((++) "runTest called error: " pprint t)
- In the untyped splice:
- $(do VarI _ t _ <- reify (mkName "prop_x1")
- error $ ("runTest called error: " ++ pprint t))
+ Code: do VarI _ t _ <- reify (mkName "prop_x1")
+ error $ ("runTest called error: " ++ pprint t)
+ • In the untyped splice:
+ $(do VarI _ t _ <- reify (mkName "prop_x1")
+ error $ ("runTest called error: " ++ pprint t))
diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr
index 507d9d8b8d..f4e9568927 100644
--- a/testsuite/tests/th/T5976.stderr
+++ b/testsuite/tests/th/T5976.stderr
@@ -2,6 +2,6 @@
T5976.hs:1:1: error:
Exception when trying to run compile-time code:
bar
-CallStack (from ImplicitParams):
+CallStack (from HasCallStack):
error, called at T5976.hs:3:21 in main:Main
- Code: error ((++) "foo " error "bar")
+ Code: error ("foo " ++ error "bar")
diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr
index 1af2e29b7f..7b5f400f6f 100644
--- a/testsuite/tests/th/T8987.stderr
+++ b/testsuite/tests/th/T8987.stderr
@@ -2,7 +2,7 @@
T8987.hs:1:1: error:
Exception when trying to run compile-time code:
Prelude.undefined
-CallStack (from ImplicitParams):
- error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err
+CallStack (from HasCallStack):
+ error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
undefined, called at T8987.hs:6:23 in main:T8987
- Code: (>>) reportWarning ['1', undefined] return []
+ Code: reportWarning ['1', undefined] >> return []
diff --git a/testsuite/tests/typecheck/should_compile/T11723.hs b/testsuite/tests/typecheck/should_compile/T11723.hs
new file mode 100644
index 0000000000..1933024f2e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11723.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeInType #-}
+module Example where
+
+import Data.Typeable
+import GHC.Exts
+
+data Wat (a :: TYPE ('TupleRep '[])) = Wat a
diff --git a/testsuite/tests/typecheck/should_compile/T11736.hs b/testsuite/tests/typecheck/should_compile/T11736.hs
new file mode 100644
index 0000000000..8bcbc3e06b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11736.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module T11736 where
+
+import Data.Proxy
+
+foo :: Proxy (#,#)
+foo = Proxy
diff --git a/testsuite/tests/typecheck/should_compile/T12987.hs b/testsuite/tests/typecheck/should_compile/T12987.hs
new file mode 100644
index 0000000000..0997985601
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12987.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeInType #-}
+
+module T12987 where
+
+import GHC.Exts
+
+class NUM (a :: TYPE rep) where add :: a -> a -> a
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index b70ab83b34..c5e9163bbe 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -565,3 +565,6 @@ test('T12919', expect_broken(12919), compile, [''])
test('T12936', normal, compile, [''])
test('T13050', normal, compile, ['-fdefer-type-errors'])
test('T13083', normal, compile, [''])
+test('T11723', normal, compile, [''])
+test('T12987', normal, compile, [''])
+test('T11736', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs b/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs
deleted file mode 100644
index 2935416538..0000000000
--- a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# LANGUAGE TypeFamilies, KindSignatures, TypeInType #-}
-
-module BadUnboxedTuple where
-
-import GHC.Exts
-
-type family F :: TYPE UnboxedTupleRep
-
-foo :: F -> ()
-foo _ = ()
diff --git a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr b/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr
deleted file mode 100644
index 7c5ad5762f..0000000000
--- a/testsuite/tests/typecheck/should_fail/BadUnboxedTuple.stderr
+++ /dev/null
@@ -1,6 +0,0 @@
-
-BadUnboxedTuple.hs:10:5: error:
- The type ‘F’ is not an unboxed tuple,
- and yet its kind suggests that it has the representation
- of an unboxed tuple. This is not allowed.
- In a wildcard pattern
diff --git a/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs b/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs
new file mode 100644
index 0000000000..0607956784
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/LevPolyBounded.hs
@@ -0,0 +1,11 @@
+-- inspired by comment:25 on #12708
+
+{-# LANGUAGE TypeInType #-}
+
+module LevPolyBounded where
+
+import GHC.Exts
+
+class XBounded (a :: TYPE r) where
+ minBound :: a
+ maxBound :: a
diff --git a/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr
new file mode 100644
index 0000000000..21ae68ab85
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr
@@ -0,0 +1,5 @@
+
+LevPolyBounded.hs:10:15: error:
+ • Expected a type, but ‘a’ has kind ‘TYPE r’
+ • In the type signature: LevPolyBounded.minBound :: a
+ In the class declaration for ‘XBounded’
diff --git a/testsuite/tests/typecheck/should_fail/StrictBinds.hs b/testsuite/tests/typecheck/should_fail/StrictBinds.hs
new file mode 100644
index 0000000000..bd951f96b1
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/StrictBinds.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash #-}
+
+module StrictBinds where
+
+import GHC.Exts
+
+foo = let x = 3# +# y
+ y = x in
+ True
diff --git a/testsuite/tests/typecheck/should_fail/StrictBinds.stderr b/testsuite/tests/typecheck/should_fail/StrictBinds.stderr
new file mode 100644
index 0000000000..082d71176a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/StrictBinds.stderr
@@ -0,0 +1,5 @@
+
+StrictBinds.hs:7:11: error:
+ Recursive bindings for unlifted types aren't allowed:
+ x = 3# +# y
+ y = x
diff --git a/testsuite/tests/typecheck/should_fail/T11723.hs b/testsuite/tests/typecheck/should_fail/T11723.hs
deleted file mode 100644
index 4761cc4131..0000000000
--- a/testsuite/tests/typecheck/should_fail/T11723.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE KindSignatures #-}
-module Example where
-
-import Data.Typeable
-import GHC.Exts
-
-data Wat (a :: TYPE 'UnboxedTupleRep) = Wat a
diff --git a/testsuite/tests/typecheck/should_fail/T11723.stderr b/testsuite/tests/typecheck/should_fail/T11723.stderr
deleted file mode 100644
index b63a182d2c..0000000000
--- a/testsuite/tests/typecheck/should_fail/T11723.stderr
+++ /dev/null
@@ -1,7 +0,0 @@
-
-T11723.hs:8:41: error:
- • The type ‘a’ is not an unboxed tuple,
- and yet its kind suggests that it has the representation
- of an unboxed tuple. This is not allowed.
- • In the definition of data constructor ‘Wat’
- In the data type declaration for ‘Wat’
diff --git a/testsuite/tests/typecheck/should_fail/T11724.stderr b/testsuite/tests/typecheck/should_fail/T11724.stderr
index 2971b27597..dbdbb6fdef 100644
--- a/testsuite/tests/typecheck/should_fail/T11724.stderr
+++ b/testsuite/tests/typecheck/should_fail/T11724.stderr
@@ -1,6 +1,6 @@
T11724.hs:7:44: error:
- • A representation-polymorphic type is not allowed here:
+ • A levity-polymorphic type is not allowed here:
Type: a
Kind: TYPE r
• In the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/T12973.hs b/testsuite/tests/typecheck/should_fail/T12973.hs
new file mode 100644
index 0000000000..624d24be24
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12973.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE RebindableSyntax, TypeInType, ExplicitForAll #-}
+
+module T12973 where
+
+import qualified Prelude as P
+import GHC.Exts
+
+class Num (a :: TYPE r) where
+ (+) :: a -> a -> a
+ fromInteger :: P.Integer -> a
+
+foo :: forall (a :: TYPE r). Num a => a
+foo = 3 + 4
+
+
diff --git a/testsuite/tests/typecheck/should_fail/T12973.stderr b/testsuite/tests/typecheck/should_fail/T12973.stderr
new file mode 100644
index 0000000000..a6d97009cd
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12973.stderr
@@ -0,0 +1,12 @@
+
+T12973.hs:13:7: error:
+ A levity-polymorphic type is not allowed here:
+ Type: a
+ Kind: TYPE r
+ In the type of expression: 3
+
+T12973.hs:13:11: error:
+ A levity-polymorphic type is not allowed here:
+ Type: a
+ Kind: TYPE r
+ In the type of expression: 4
diff --git a/testsuite/tests/typecheck/should_fail/T13105.hs b/testsuite/tests/typecheck/should_fail/T13105.hs
new file mode 100644
index 0000000000..44384dc19d
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13105.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE UnicodeSyntax, MagicHash, TypeInType, TypeFamilies #-}
+
+-- from Conal Elliott
+-- Actually, this *should* work. But I want to put it in the testsuite
+-- as a succeeding "compile_fail" test to make sure that we don't panic.
+
+module RepRep where
+
+import GHC.Exts
+
+type family RepRep a ∷ RuntimeRep
+
+class HasRep a where
+ type Rep a ∷ TYPE (RepRep a)
+ repr ∷ a → Rep a
+ abst ∷ Rep a → a
+
+type instance RepRep Int = IntRep
+
+instance HasRep Int where
+ type Rep Int = Int#
+ abst n = I# n
+ repr (I# n) = n
diff --git a/testsuite/tests/typecheck/should_fail/T13105.stderr b/testsuite/tests/typecheck/should_fail/T13105.stderr
new file mode 100644
index 0000000000..c54327ef70
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13105.stderr
@@ -0,0 +1,6 @@
+
+T13105.hs:22:8: error:
+ A levity-polymorphic type is not allowed here:
+ Type: Rep Int
+ Kind: TYPE (RepRep Int)
+ In the type of binder ‘n’
diff --git a/testsuite/tests/typecheck/should_fail/T2806.hs b/testsuite/tests/typecheck/should_fail/T2806.hs
index 6ada5d83fb..ac95542c94 100644
--- a/testsuite/tests/typecheck/should_fail/T2806.hs
+++ b/testsuite/tests/typecheck/should_fail/T2806.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -Wunbanged-strict-patterns #-}
-- Trac #2806
@@ -10,4 +11,3 @@ import GHC.Base
foo :: Int
foo = 3
where (I# _x) = 4
-
diff --git a/testsuite/tests/typecheck/should_fail/T2806.stderr b/testsuite/tests/typecheck/should_fail/T2806.stderr
index 25cc8e65a0..02a4d81c15 100644
--- a/testsuite/tests/typecheck/should_fail/T2806.stderr
+++ b/testsuite/tests/typecheck/should_fail/T2806.stderr
@@ -1,9 +1,5 @@
-T2806.hs:12:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+T2806.hs:13:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
(I# _x) = 4
- In an equation for ‘foo’:
- foo
- = 3
- where
- (I# _x) = 4
diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr
index b45363bdc3..62a4210443 100644
--- a/testsuite/tests/typecheck/should_fail/T6078.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6078.stderr
@@ -1,11 +1,5 @@
T6078.hs:8:10: error:
- You can't mix polymorphic and unlifted bindings
+ You can't mix polymorphic and unlifted bindings:
ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
- Probable fix: add a type signature
- In the expression:
- let ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len in ip1p
- In the expression:
- \ fpbuf ip0 ipe s0 -> let ip1p@(Ptr ip1) = ... in ip1p
- In an equation for ‘byteStringSlice’:
- byteStringSlice len = \ fpbuf ip0 ipe s0 -> let ... in ip1p
+ Probable fix: add a type signature
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index c490fec10e..9931037e4e 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -187,7 +187,7 @@ test('tcfail199', normal, compile_fail, [''])
test('tcfail200', normal, compile_fail, [''])
test('tcfail201', normal, compile_fail, [''])
test('tcfail202', normal, compile_fail, [''])
-test('tcfail203', normal, compile_fail, [''])
+test('tcfail203', normal, compile, [''])
test('tcfail203a', normal, compile_fail, [''])
test('tcfail204', normal, compile_fail, [''])
test('tcfail206', normal, compile_fail, [''])
@@ -204,7 +204,7 @@ test('T2994', normal, compile_fail, [''])
test('T3155', normal, compile_fail, [''])
test('T3176', normal, compile_fail, [''])
test('T1633', normal, compile_fail, [''])
-test('T2806', normal, compile_fail, [''])
+test('T2806', normal, compile, [''])
test('T3323', normal, compile_fail, [''])
test('T3406', normal, compile_fail, [''])
test('T3540', normal, compile_fail, [''])
@@ -406,9 +406,7 @@ test('T11563', normal, compile_fail, [''])
test('T11541', normal, compile_fail, [''])
test('T11313', normal, compile_fail, [''])
test('T11623', normal, compile_fail, [''])
-test('T11723', normal, compile_fail, [''])
test('T11724', normal, compile_fail, [''])
-test('BadUnboxedTuple', normal, compile_fail, [''])
test('T11698', normal, compile_fail, [''])
test('T11947a', normal, compile_fail, [''])
test('T11948', normal, compile_fail, [''])
@@ -435,3 +433,7 @@ test('T12042', extra_clean(['T12042a.hi', 'T12042a.o', 'T12042.hi-boot', 'T12042
test('T12966', normal, compile_fail, [''])
test('T12837', normal, compile_fail, [''])
test('T12921', normal, compile_fail, [''])
+test('T12973', normal, compile_fail, [''])
+test('StrictBinds', normal, compile_fail, [''])
+test('T13105', normal, compile_fail, [''])
+test('LevPolyBounded', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.hs b/testsuite/tests/typecheck/should_fail/tcfail203.hs
index 7f51dae3b5..096cf5796b 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail203.hs
+++ b/testsuite/tests/typecheck/should_fail/tcfail203.hs
@@ -1,6 +1,7 @@
-- trac #2806
{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
+{-# OPTIONS_GHC -Wunbanged-strict-patterns #-}
module Foo where
diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.stderr b/testsuite/tests/typecheck/should_fail/tcfail203.stderr
index 21454e345d..d9f7087229 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail203.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail203.stderr
@@ -1,36 +1,40 @@
-tcfail203.hs:28:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+tcfail203.hs:29:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
(I# x) = 5
- In an equation for ‘fail2’:
- fail2
- = 'a'
- where
- (I# x) = 5
-
-tcfail203.hs:31:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+
+tcfail203.hs:32:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
(b, I# x) = (True, 5)
- In an equation for ‘fail3’:
- fail3
- = 'a'
- where
- (b, I# x) = (True, 5)
-
-tcfail203.hs:40:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+
+tcfail203.hs:35:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
+ (# b, I# x #) = (# True, 5 #)
+
+tcfail203.hs:38:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
+ (# b, x #) = (# True, 5# #)
+
+tcfail203.hs:41:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
(I# !x) = 5
- In an equation for ‘fail6’:
- fail6
- = 'a'
- where
- (I# !x) = 5
-
-tcfail203.hs:43:11:
- Pattern bindings containing unlifted types should use an outermost bang pattern:
+
+tcfail203.hs:44:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
(b, !(I# x)) = (True, 5)
- In an equation for ‘fail7’:
- fail7
- = 'a'
- where
- (b, !(I# x)) = (True, 5)
+
+tcfail203.hs:47:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
+ (# b, !(I# x) #) = (# True, 5 #)
+
+tcfail203.hs:50:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
+ Pattern bindings containing unlifted types should use
+ an outermost bang pattern:
+ (# b, !x #) = (# True, 5# #)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail203a.stderr b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr
index 272ff4254e..153a9259ba 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail203a.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr
@@ -1,6 +1,5 @@
-tcfail203a.hs:10:16:
- A lazy (~) pattern cannot contain unlifted types: ~(c, (I# x))
- In the pattern: ~(c, (I# x))
- In the pattern: (b, ~(c, (I# x)))
- In the pattern: !(b, ~(c, (I# x)))
+tcfail203a.hs:10:17: error:
+ A lazy (~) pattern cannot bind variables of unlifted type.
+ Unlifted variables:
+ x :: Int#
diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs
new file mode 100644
index 0000000000..e912411209
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE UnboxedTuples, MagicHash, GADTs, TypeInType, ExplicitForAll #-}
+
+
+module Main where
+
+import GHC.Exts
+
+data G a where
+ MkG :: G (TupleRep [LiftedRep, IntRep])
+
+-- tests that we don't eta-expand functions that are levity-polymorphic
+-- see CoreArity.mkEtaWW
+foo :: forall a (b :: TYPE a). G a -> b -> b
+foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [LiftedRep, IntRep])). c -> c
+
+data H a where
+ MkH :: H IntRep
+
+-- tests that we don't push coercions that make args levity-polymorphic
+-- see Simplify.simplCast
+bar :: forall (r :: RuntimeRep) (a :: TYPE r). H r -> (a -> a -> (# a, a #)) -> a -> (# a, a #)
+bar MkH = (\f x -> f x x) :: forall (b :: TYPE IntRep). (b -> b -> (# b, b #)) -> b -> (# b, b #)
+
+main :: IO ()
+main = do
+ let (# b, x #) = foo MkG (# True, 3# #)
+ print b
+ print (I# x)
+
+ let (# y, z #) = bar MkH (#,#) 8#
+ print (I# y)
+ print (I# z)
diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout
new file mode 100644
index 0000000000..97c6c910ed
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.stdout
@@ -0,0 +1,4 @@
+True
+3
+8
+8
diff --git a/testsuite/tests/typecheck/should_run/KindInvariant.stderr b/testsuite/tests/typecheck/should_run/KindInvariant.stderr
index 3fe8131daf..4f6cfffb7f 100644
--- a/testsuite/tests/typecheck/should_run/KindInvariant.stderr
+++ b/testsuite/tests/typecheck/should_run/KindInvariant.stderr
@@ -1,6 +1,6 @@
<interactive>:1:3: error:
• Expected kind ‘* -> *’,
- but ‘State#’ has kind ‘* -> TYPE 'VoidRep’
+ but ‘State#’ has kind ‘* -> TYPE ('TupleRep '[])’
• In the first argument of ‘T’, namely ‘State#’
In the type ‘T State#’
diff --git a/testsuite/tests/typecheck/should_run/StrictPats.hs b/testsuite/tests/typecheck/should_run/StrictPats.hs
new file mode 100644
index 0000000000..7eed9dc767
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/StrictPats.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE BangPatterns, TypeApplications, UnboxedTuples, MagicHash,
+ UnboxedSums, NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-unused-binds -Wno-unbanged-strict-patterns #-}
+
+module Main where
+
+import Control.Exception
+import GHC.Exts
+
+-- This stress-tests the semantics of strict patterns.
+
+ok :: a -> IO ()
+ok x = do
+ evaluate x
+ putStrLn "Evaluation successful."
+
+bad :: a -> IO ()
+bad x = do
+ r <- try @SomeException $ evaluate x
+ case r of
+ Left _ -> putStrLn "Exception thrown as expected."
+ Right _ -> putStrLn "Exception not thrown when expected."
+
+-- OK
+a = True
+ where x :: Num a => a
+ !x = undefined -- x is a function. Should be OK.
+
+-- should fail
+b = True
+ where x :: a
+ !x = undefined
+
+-- OK
+c = True
+ where I# _ = undefined
+
+-- bad
+d = True
+ where I# _x = undefined
+
+-- OK
+e = True
+ where _ = undefined :: Int#
+
+-- bad
+f = True
+ where _x = undefined :: Int#
+
+-- OK
+g = True
+ where (# _ #) = undefined
+
+-- OK
+h = True
+ where (# _x #) = undefined
+
+-- bad
+i = True
+ where (# _x #) = undefined :: (# Int# #)
+
+-- bad
+j = True
+ where !True = False
+
+-- OK
+k = True
+ where True = False
+
+-- OK
+l = True
+ where 3# = 4#
+
+-- bad
+m = True
+ where !3# = 4#
+
+-- bad
+n = True
+ where _x = undefined :: (# () #)
+
+-- OK
+o = True
+ where (# _x #) = undefined :: (# () #)
+
+-- OK
+p = True
+ where (# _ | #) = (# | True #)
+
+-- bad
+q = True
+ where (# _x | #) = (# | True #) :: (# Int# | Bool #)
+
+-- OK
+r = True
+ where (# _x | #) = (# | True #)
+
+-- bad
+s = True
+ where !(# x #) = undefined
+
+main :: IO ()
+main = do
+ ok a
+ bad b
+ ok c
+ bad d
+ ok e
+ bad f
+ ok g
+ ok h
+ bad i
+ bad j
+ ok k
+ ok l
+ bad m
+ bad n
+ ok o
+ ok p
+ bad q
+ ok r
+ bad s
diff --git a/testsuite/tests/typecheck/should_run/StrictPats.stdout b/testsuite/tests/typecheck/should_run/StrictPats.stdout
new file mode 100644
index 0000000000..509df4e246
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/StrictPats.stdout
@@ -0,0 +1,19 @@
+Evaluation successful.
+Exception thrown as expected.
+Evaluation successful.
+Exception thrown as expected.
+Evaluation successful.
+Exception thrown as expected.
+Evaluation successful.
+Evaluation successful.
+Exception thrown as expected.
+Exception thrown as expected.
+Evaluation successful.
+Evaluation successful.
+Exception thrown as expected.
+Exception thrown as expected.
+Evaluation successful.
+Evaluation successful.
+Exception thrown as expected.
+Evaluation successful.
+Exception thrown as expected.
diff --git a/testsuite/tests/typecheck/should_run/T12809.hs b/testsuite/tests/typecheck/should_run/T12809.hs
new file mode 100644
index 0000000000..9f6da26d76
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T12809.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TypeInType, ExplicitForAll, MagicHash, UnboxedTuples,
+ TypeFamilies, GADTs #-}
+
+module Main where
+
+import GHC.Exts
+
+idint :: forall (a :: TYPE IntRep). a -> a
+idint x = x
+
+five _ = idint 3# +# idint 2#
+
+type family F a where
+ F Int = (# Bool, Int# #)
+ F Char = (# Double, Int# #)
+
+data G a where
+ GInt :: G Int
+ GChar :: G Char
+
+f :: G a -> F a
+f GInt = (# True, 3# #)
+f GChar = (# 3.14, 5# #)
+
+f' :: G a -> F a
+f' GInt = (# False, 7# #)
+f' GChar = (# 2.71829, 11# #)
+
+g :: (# Bool, Int# #) -> String
+g (# b, x #) = show b ++ " " ++ show (I# x)
+
+h :: (# Double, Int# #) -> String
+h (# d, x #) = show d ++ " " ++ show (I# x)
+
+cond :: forall (a :: TYPE (TupleRep [LiftedRep, IntRep])). Bool -> a -> a -> a
+cond True x _ = x
+cond False _ x = x
+
+main :: IO ()
+main = do
+ print (I# (five ()))
+ putStrLn (g (f GInt))
+ putStrLn (g (cond False (f GInt) (f' GInt)))
+ putStrLn (h (cond True (f GChar) (f' GChar)))
diff --git a/testsuite/tests/typecheck/should_run/T12809.stdout b/testsuite/tests/typecheck/should_run/T12809.stdout
new file mode 100644
index 0000000000..5d187d8652
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T12809.stdout
@@ -0,0 +1,4 @@
+5
+True 3
+False 7
+3.14 5
diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs
index 53e035923f..59ea6fdf0d 100644
--- a/testsuite/tests/typecheck/should_run/TypeOf.hs
+++ b/testsuite/tests/typecheck/should_run/TypeOf.hs
@@ -27,9 +27,9 @@ main = do
print $ typeOf (Proxy :: Proxy [1,2,3])
print $ typeOf (Proxy :: Proxy 'EQ)
print $ typeOf (Proxy :: Proxy TYPE)
- print $ typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted))
+ print $ typeOf (Proxy :: Proxy (TYPE 'LiftedRep))
print $ typeOf (Proxy :: Proxy *)
print $ typeOf (Proxy :: Proxy ★)
- print $ typeOf (Proxy :: Proxy 'PtrRepLifted)
+ print $ typeOf (Proxy :: Proxy 'LiftedRep)
print $ typeOf (Proxy :: Proxy '(1, "hello"))
print $ typeOf (Proxy :: Proxy (~~))
diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout
index 3e3396fa7e..99f113cf00 100644
--- a/testsuite/tests/typecheck/should_run/TypeOf.stdout
+++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout
@@ -19,6 +19,6 @@ Proxy (RuntimeRep -> Constraint) TYPE
Proxy Constraint Constraint
Proxy Constraint Constraint
Proxy Constraint Constraint
-Proxy RuntimeRep 'PtrRepLifted
+Proxy RuntimeRep 'LiftedRep
Proxy (Nat,Symbol) ('(,) Nat Symbol 1 "hello")
Proxy (Constraint -> Constraint -> Constraint) ~~
diff --git a/testsuite/tests/typecheck/should_run/TypeRep.hs b/testsuite/tests/typecheck/should_run/TypeRep.hs
index 3ae9577088..5fbf909193 100644
--- a/testsuite/tests/typecheck/should_run/TypeRep.hs
+++ b/testsuite/tests/typecheck/should_run/TypeRep.hs
@@ -39,10 +39,10 @@ main = do
print $ rep @(Proxy [1,2,3])
print $ rep @(Proxy 'EQ)
print $ rep @(Proxy TYPE)
- print $ rep @(Proxy (TYPE 'PtrRepLifted))
+ print $ rep @(Proxy (TYPE 'LiftedRep))
print $ rep @(Proxy *)
print $ rep @(Proxy ★)
- print $ rep @(Proxy 'PtrRepLifted)
+ print $ rep @(Proxy 'LiftedRep)
-- Something lifted and primitive
print $ rep @RealWorld
diff --git a/testsuite/tests/typecheck/should_run/TypeRep.stdout b/testsuite/tests/typecheck/should_run/TypeRep.stdout
index de008640f4..09b4cea574 100644
--- a/testsuite/tests/typecheck/should_run/TypeRep.stdout
+++ b/testsuite/tests/typecheck/should_run/TypeRep.stdout
@@ -20,5 +20,5 @@ Proxy (RuntimeRep -> Constraint) TYPE
Proxy Constraint Constraint
Proxy Constraint Constraint
Proxy Constraint Constraint
-Proxy RuntimeRep 'PtrRepLifted
+Proxy RuntimeRep 'LiftedRep
RealWorld
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index fa6273a06d..ac63f98508 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -117,3 +117,6 @@ test('TypeOf', normal, compile_and_run, [''])
test('TypeRep', normal, compile_and_run, [''])
test('T11120', normal, compile_and_run, [''])
test('KindInvariant', normal, ghci_script, ['KindInvariant.script'])
+test('StrictPats', normal, compile_and_run, [''])
+test('T12809', normal, compile_and_run, [''])
+test('EtaExpandLevPoly', normal, compile_and_run, [''])
diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout
index 13070dfe77..7a623a3bd6 100644
--- a/testsuite/tests/unboxedsums/T12711.stdout
+++ b/testsuite/tests/unboxedsums/T12711.stdout
@@ -1 +1,2 @@
-(# _ | _ #) :: TYPE 'GHC.Types.UnboxedSumRep
+(# _ | _ #) :: TYPE
+ ('GHC.Types.SumRep '['GHC.Types.LiftedRep, 'GHC.Types.LiftedRep])
diff --git a/testsuite/tests/unboxedsums/UbxSumLevPoly.hs b/testsuite/tests/unboxedsums/UbxSumLevPoly.hs
new file mode 100644
index 0000000000..3275eb7dfe
--- /dev/null
+++ b/testsuite/tests/unboxedsums/UbxSumLevPoly.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module UbxSumLevPoly where
+
+-- this failed thinking that (# Any | True #) :: TYPE (SumRep [LiftedRep, b])
+-- But of course that b should be Lifted!
+
+-- It was due to silliness in TysWiredIn using the same uniques for different
+-- things in mk_sum.
+
+p = True
+ where (# _x | #) = (# | True #)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index 290ae43263..eea818b6f1 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -21,7 +21,7 @@ test('ffi1', normal, compile_fail, [''])
test('thunk', only_ways(['normal']), compile_and_run, [''])
test('T12375', only_ways(['normal']), compile_and_run, [''])
test('empty_sum', only_ways(['normal']), compile_and_run, [''])
-test('sum_rr', normal, compile_fail, [''])
+test('sum_rr', normal, compile, [''])
test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
# TODO: Need to run this in --slow mode only
@@ -30,3 +30,5 @@ test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
# extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
# run_command,
# ['$MAKE -s --no-print-directory sum_api_annots'])
+
+test('UbxSumLevPoly', normal, compile, [''])
diff --git a/testsuite/tests/unboxedsums/sum_rr.hs b/testsuite/tests/unboxedsums/sum_rr.hs
index 287edcf452..5f799fe481 100644
--- a/testsuite/tests/unboxedsums/sum_rr.hs
+++ b/testsuite/tests/unboxedsums/sum_rr.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE DataKinds, KindSignatures #-}
+{-# LANGUAGE TypeInType #-}
module Example where
import Data.Typeable
import GHC.Exts
-data Wat (a :: TYPE 'UnboxedSumRep) = Wat a
+data Wat (a :: TYPE (SumRep '[LiftedRep, IntRep])) = Wat a
diff --git a/testsuite/tests/unboxedsums/sum_rr.stderr b/testsuite/tests/unboxedsums/sum_rr.stderr
deleted file mode 100644
index 2ac9b7452f..0000000000
--- a/testsuite/tests/unboxedsums/sum_rr.stderr
+++ /dev/null
@@ -1,7 +0,0 @@
-
-sum_rr.hs:8:39: error:
- • The type ‘a’ is not an unboxed sum,
- and yet its kind suggests that it has the representation
- of an unboxed sum. This is not allowed.
- • In the definition of data constructor ‘Wat’
- In the data type declaration for ‘Wat’
diff --git a/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
index 399e074991..0b6384b6ba 100644
--- a/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
+++ b/testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs
@@ -46,7 +46,7 @@ layout_tests = sequence_
where
assert_layout tn tys layout =
let
- layout_ret = ubxSumRepType tys
+ layout_ret = ubxSumRepType (map typePrimRep tys)
in
assert (layout_ret == layout)
tn