diff options
author | sheaf <sam.derbyshire@gmail.com> | 2022-05-25 17:29:14 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-26 17:38:43 -0400 |
commit | 88e586004abac9404307f6e19c86d7fd5c4ad5f1 (patch) | |
tree | e2f45c58d3c9a2e99195848758cac528de6cf4ac | |
parent | 44bb71115bcf1edaee82fc75cbe07a3e242e9476 (diff) | |
download | haskell-88e586004abac9404307f6e19c86d7fd5c4ad5f1.tar.gz |
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.
-rw-r--r-- | testsuite/tests/linear/should_compile/LinearDataConSections.hs | 17 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandDataCon.hs | 78 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandDataFamily.hs | 29 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandNewtypeTF.hs | 28 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandNewtypeTF2.hs | 37 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandStupid1.hs | 52 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandStupid2.hs | 19 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/EtaExpandStupid2.stderr | 9 | ||||
-rw-r--r-- | testsuite/tests/rep-poly/all.T | 6 |
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, ['']) |