[Git][ghc/ghc][wip/9.4.6-backports] Add tests for eta-expansion of data constructors
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Thu Aug 3 22:54:08 UTC 2023
Zubin pushed to branch wip/9.4.6-backports at Glasgow Haskell Compiler / GHC
Commits:
347dc6a8 by sheaf at 2023-08-04T04:22:19+05:30
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 changed files:
- + testsuite/tests/linear/should_compile/LinearDataConSections.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/rep-poly/EtaExpandDataCon.hs
- + testsuite/tests/rep-poly/EtaExpandDataFamily.hs
- + testsuite/tests/rep-poly/EtaExpandNewtypeTF.hs
- + testsuite/tests/rep-poly/EtaExpandNewtypeTF2.hs
- + testsuite/tests/rep-poly/EtaExpandStupid1.hs
- + testsuite/tests/rep-poly/EtaExpandStupid2.hs
- + testsuite/tests/rep-poly/EtaExpandStupid2.stderr
- testsuite/tests/rep-poly/all.T
Changes:
=====================================
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
=====================================
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, [''])
=====================================
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##)
=====================================
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
=====================================
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
=====================================
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
=====================================
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##
=====================================
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
=====================================
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#)
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -30,6 +30,10 @@ test('T20426', normal, compile_fail, [''])
test('T21239', normal, compile, [''])
test('T21544', normal, compile, ['-Wno-deprecated-flags'])
+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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/347dc6a879ec3f86079d2aa3d376b09189071c08
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/347dc6a879ec3f86079d2aa3d376b09189071c08
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230803/d13a13a1/attachment-0001.html>
More information about the ghc-commits
mailing list