Add tests for eta-expansion of data constructors

This patch adds several tests relating to the eta-expansion of
data constructors, including UnliftedNewtypes and DataTypeContexts.

10 files changed, 276 insertions, 0 deletions

diff --git a/testsuite/tests/linear/should_compile/LinearDataConSections.hs b/testsuite/tests/linear/should_compile/LinearDataConSections.hs
new file mode 100644
index 0000000000..8a71a494c8
--- /dev/null
+++ b/testsuite/tests/linear/should_compile/LinearDataConSections.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds, LinearTypes, GADTSyntax #-}
+
+module LinearDataConSections where
+
+import GHC.Types ( Multiplicity(..) )
+
+-- Check that we correctly eta-expand left and right sections
+-- of data-constructors to change multiplicities from One to Many
+
+data D where
+  MkD :: Bool %1 -> Char %1 -> D
+
+foo :: Char %Many -> D
+foo = (True `MkD`)
+
+bar :: Bool %Many -> D
+bar = (`MkD` 'y')
\ No newline at end of file
diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T
index 49171262e4..111ba6751a 100644
--- a/testsuite/tests/linear/should_compile/all.T
+++ b/testsuite/tests/linear/should_compile/all.T
@@ -35,6 +35,7 @@ test('LinearTH2', normal, compile, [''])
 test('LinearTH3', normal, compile, [''])
 test('LinearTH4', normal, compile, [''])
 test('LinearHole', normal, compile, [''])
+test('LinearDataConSections', normal, compile, [''])
 test('T18731', normal, compile, [''])
 test('T19400', unless(compiler_debugged(), skip), compile, [''])
 test('T20023', normal, compile, [''])
diff --git a/testsuite/tests/rep-poly/EtaExpandDataCon.hs b/testsuite/tests/rep-poly/EtaExpandDataCon.hs
new file mode 100644
index 0000000000..fb4618578a
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandDataCon.hs
@@ -0,0 +1,78 @@
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+
+module EtaExpandDataCon where
+
+import Data.Coerce
+import Data.Kind
+import GHC.Exts
+
+-- Simple eta-expansion tests.
+
+type D1 :: Type -> Type
+data D1 a where
+  MkD1 :: Ord a => Float# -> Int -> a %1 -> D1 a
+
+foo1 :: Ord a => Float# -> Int -> a -> D1 a
+foo1 x1 = MkD1 ( x1 `powerFloat#` 1234.0# )
+  -- Only the last argument needs us to change the multiplicity,
+  -- but this means adding lambdas for intervening arguments:
+  -- foo x1 = \ x2 x3 -> MkG x1 x2 x3
+
+type D2 :: Type -> Type -> Type
+data D2 a b where
+  MkD2 :: forall a b. a %1 -> b %1 -> a %1 -> D2 a b
+
+foo2 :: forall c d. (c -> c) -> c -> d -> c -> D2 c d
+foo2 very_big arg0 = MkD2 (very_big arg0)
+
+type N3 :: TYPE r -> Type
+newtype N3 a where
+  MkN3 :: forall r (a :: TYPE r). (a %1 -> N3 a) %1 -> N3 a
+
+foo3 :: (a %1 -> N3 a) -> N3 a
+foo3 = MkN3
+
+type D4 :: TYPE FloatRep -> Type -> Type
+data D4 a b = MkD4 a b b
+
+foo4 :: Bool -> Bool -> D4 Float# Bool
+foo4 = MkD4 ( 9.0# `timesFloat#` 17.0# )
+
+-- Nightmare stress test with all features:
+--
+--  - Boxed dictionary and equality constraints
+--  - GADT equality constraints
+--  - unpacking
+--  - levity-polymorphic result kind
+
+data Unpackable = Unpackable Double# Double# Double# Double#
+
+type F :: k -> k
+type family F a = r | r -> a where
+
+type G :: Type -> forall k. k -> Type -> Type -> forall l -> TYPE (BoxedRep l)
+data G a b c d l where
+  MkG :: (Ord a, F Int ~ Bool, Coercible (F Bool) Char, Eq x)
+      => Float#
+      -> {-# UNPACK #-} !Unpackable
+      -> {-# UNPACK #-} !Unpackable
+   %1 -> a
+   %1 -> (a -> x)
+   %1 -> x
+   %1 -> G a (F b) a Double l
+
+bar :: (F Bool ~ Char, F Int ~ Bool, Ord a)
+    => Unpackable
+ %1 -> a
+    -> (a -> Int)
+ %1 -> Int
+    -> G a (F b) a Double Unlifted
+bar = MkG 1728.0# (Unpackable 1.0## 2.0## 3.0## 4.0##)
diff --git a/testsuite/tests/rep-poly/EtaExpandDataFamily.hs b/testsuite/tests/rep-poly/EtaExpandDataFamily.hs
new file mode 100644
index 0000000000..02475f6cb1
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandDataFamily.hs
@@ -0,0 +1,29 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DatatypeContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+
+module EtaExpandDataFamily where
+
+import Data.Kind
+import GHC.Exts
+
+
+type N :: forall (r :: RuntimeRep) -> TYPE r -> TYPE r
+data family N r a
+newtype instance N r a = MkN a
+
+foo :: Int# -> N IntRep Int#
+foo = MkN
+
+
+type N :: forall (r :: RuntimeRep) -> TYPE r -> Type -> Type -> Type -> TYPE r
+data family N r a i
+newtype instance Ord b => N r a Int b c = MkN a
+
+foo :: Ord b => Int# -> N IntRep Int# Int b c
+foo = MkN
diff --git a/testsuite/tests/rep-poly/EtaExpandNewtypeTF.hs b/testsuite/tests/rep-poly/EtaExpandNewtypeTF.hs
new file mode 100644
index 0000000000..9145e796b2
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandNewtypeTF.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DataKinds, DatatypeContexts, MagicHash, UnliftedNewtypes, TypeFamilies #-}
+
+module EtaExpandNewtypeTF where
+
+import Data.Kind
+import GHC.Exts
+
+type R :: Type -> RuntimeRep
+type family R a where
+  R Float  = FloatRep
+  R Double = DoubleRep
+
+type F :: forall (a :: Type) -> TYPE (R a)
+type family F a where
+  F Float  = Float#
+  F Double = Double#
+
+type C :: Type -> Constraint
+class C a where {}
+
+type N :: forall (a :: Type) -> TYPE (R a)
+newtype C a => N a = MkN (F a)
+
+foo1 :: C Float => F Float -> N Float
+foo1 = MkN
+
+foo2 :: C Double => () -> F Double -> N Double
+foo2 _ = MkN
diff --git a/testsuite/tests/rep-poly/EtaExpandNewtypeTF2.hs b/testsuite/tests/rep-poly/EtaExpandNewtypeTF2.hs
new file mode 100644
index 0000000000..ba973ae1f9
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandNewtypeTF2.hs
@@ -0,0 +1,37 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DatatypeContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+{-# LANGUAGE LinearTypes #-}
+
+module EtaExpandNewtypeTF2 where
+
+import Data.Kind
+import GHC.Exts
+
+
+data T1
+
+type RR :: Type -> Type -> RuntimeRep
+type family RR t1 t2 where
+  RR T1 _ = IntRep
+
+type C1 :: Type -> Constraint
+class    C1 t
+instance C1 T1
+
+type C2 :: Type -> Constraint
+class C2 t
+
+
+type N :: forall t1 t2 -> TYPE (RR t1 t2) -> TYPE (RR t1 t2)
+newtype (C1 t1, C2 t2) => N t1 t2 a = MkN a
+
+foo :: forall t2 (a :: TYPE (RR T1 t2)). C2 t2 => a -> N T1 t2 a
+foo = MkN
+
+bar :: forall t2 (a :: TYPE (RR T1 t2)). C2 t2 => a %1 -> N T1 t2 a
+bar = MkN
diff --git a/testsuite/tests/rep-poly/EtaExpandStupid1.hs b/testsuite/tests/rep-poly/EtaExpandStupid1.hs
new file mode 100644
index 0000000000..128af95937
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandStupid1.hs
@@ -0,0 +1,52 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DatatypeContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+
+module EtaExpandStupid1 where
+
+import Data.Kind
+import Data.Typeable ( Typeable )
+import GHC.Exts
+
+
+--T4809-like
+type D3 :: Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type
+data family D3 a1 a2 a3 a4 xxx1 xxx2 xxx3 c1 c2 c3 c4
+newtype instance D3 a1 a2 a34 a34 Int Word Char c1 c2 c34 c34 c555 c555 c555 where
+  MkD3 :: forall a34' c555' a1' a2' c1' c2' c34'. Maybe c2' -> D3 a1' a2' a34' a34' Int Word Char c1' c2' c34' c34' c555' c555' c555'
+
+foo :: forall b1 b2 b34 d1 d2 d34 d555. Maybe d2 -> D3 b1 b2 b34 b34 Int Word Char d1 d2 d34 d34 d555 d555 d555
+foo = MkD3 @_ @d555 @b1 @b2
+
+--tcrun029-like
+data Eq a => D a = MkD { fld1 :: a }
+
+bar :: D Bool
+bar = bar { fld1 = True }
+
+
+type D4 :: TYPE FloatRep -> Type -> Type -> Type
+data (Ord b, Typeable c, Num c) => D4 a b c = forall d. Eq d => MkD4 a b c d
+
+foo4 :: (Num c, Typeable c, Eq d) => [Maybe Int] -> c -> d -> D4 Float# [Maybe Int] c
+foo4 = MkD4 @Float# ( 9.0# `timesFloat#` 17.0# )
+
+bar4 :: D4 Float# [Maybe Int] Int
+bar4 = foo4 [Just 2, Nothing] 11 False
+
+
+type C :: TYPE r -> Constraint
+class C a where
+instance C Double#
+
+type N :: TYPE r -> TYPE r
+newtype C a => N a = MkN a
+
+quux :: Double# -> N Double#
+quux = MkN
+
+wibble _ = quux 2.0##
diff --git a/testsuite/tests/rep-poly/EtaExpandStupid2.hs b/testsuite/tests/rep-poly/EtaExpandStupid2.hs
new file mode 100644
index 0000000000..c7fb218715
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandStupid2.hs
@@ -0,0 +1,19 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DatatypeContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module EtaExpandStupid2 where
+
+import Data.Kind
+import GHC.Exts
+
+type D4 :: TYPE FloatRep -> Type -> Type -> Type
+data (Eq b, Num c) => D4 a b c = MkD4 a b c
+
+foo4 :: Int -> c -> D4 Float# Int c
+foo4 = MkD4 ( 9.0# `timesFloat#` 17.0# )
+
+  -- should fail: no evidence for Num c,
+  -- which is required by the datatype context
diff --git a/testsuite/tests/rep-poly/EtaExpandStupid2.stderr b/testsuite/tests/rep-poly/EtaExpandStupid2.stderr
new file mode 100644
index 0000000000..d0319f8628
--- /dev/null
+++ b/testsuite/tests/rep-poly/EtaExpandStupid2.stderr
@@ -0,0 +1,9 @@
+
+EtaExpandStupid2.hs:16:8: error:
+    • No instance for (Num c) arising from a use of ‘MkD4’
+      Possible fix:
+        add (Num c) to the context of
+          the type signature for:
+            foo4 :: forall c. Int -> c -> D4 Float# Int c
+    • In the expression: MkD4 (9.0# `timesFloat#` 17.0#)
+      In an equation for ‘foo4’: foo4 = MkD4 (9.0# `timesFloat#` 17.0#)
diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T
index c7f4859272..c37289e568 100644
--- a/testsuite/tests/rep-poly/all.T
+++ b/testsuite/tests/rep-poly/all.T
@@ -29,6 +29,12 @@ test('T20423b', normal, compile_fail, [''])
 test('T20426', normal, compile_fail, [''])
 test('T21239', normal, compile, [''])
 
+test('EtaExpandDataCon', normal, compile, ['-O'])
+test('EtaExpandDataFamily', expect_broken(21544), compile, [''])
+test('EtaExpandNewtypeTF', expect_broken(21650), compile, ['-Wno-deprecated-flags'])
+test('EtaExpandNewtypeTF2', expect_broken(21650), compile, ['-Wno-deprecated-flags'])
+test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
+test('EtaExpandStupid2', normal, compile_fail, ['-Wno-deprecated-flags'])
 test('LevPolyLet', normal, compile_fail, [''])
 test('PandocArrowCmd', normal, compile, [''])
 test('RepPolyApp', normal, compile_fail, [''])