diff options
Diffstat (limited to 'testsuite/tests/deriving')
39 files changed, 529 insertions, 2 deletions
diff --git a/testsuite/tests/deriving/should_compile/Roles1.hs b/testsuite/tests/deriving/should_compile/Roles1.hs new file mode 100644 index 0000000000..d0467c1a90 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE RoleAnnotations, PolyKinds #-} + +module Roles1 where + +data T1 a@N = K1 a +data T2 a@R = K2 a +data T3 (a :: k)@P = K3 +data T4 (a :: * -> *)@N b = K4 (a b) + +data T5 a = K5 a +data T6 a = K6 +data T7 a b = K7 b + diff --git a/testsuite/tests/deriving/should_compile/Roles1.stderr b/testsuite/tests/deriving/should_compile/Roles1.stderr new file mode 100644 index 0000000000..10edab13ef --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles1.stderr @@ -0,0 +1,50 @@ +TYPE SIGNATURES +TYPE CONSTRUCTORS + T1 :: * -> * + data T1 a@N + No C type associated + RecFlag NonRecursive, Promotable + = K1 :: forall a. a -> T1 a Stricts: _ + FamilyInstance: none + T2 :: * -> * + data T2 a@R + No C type associated + RecFlag NonRecursive, Promotable + = K2 :: forall a. a -> T2 a Stricts: _ + FamilyInstance: none + T3 :: forall (k :: BOX). k -> * + data T3 (k::BOX)@N (a::k)@P + No C type associated + RecFlag NonRecursive, Not promotable + = K3 :: forall (k::BOX) (a::k). T3 k a + FamilyInstance: none + T4 :: (* -> *) -> * -> * + data T4 (a::* -> *)@N b@N + No C type associated + RecFlag NonRecursive, Not promotable + = K4 :: forall (a::* -> *) b. (a b) -> T4 a b Stricts: _ + FamilyInstance: none + T5 :: * -> * + data T5 a@R + No C type associated + RecFlag NonRecursive, Promotable + = K5 :: forall a. a -> T5 a Stricts: _ + FamilyInstance: none + T6 :: forall (k :: BOX). k -> * + data T6 (k::BOX)@N (a::k)@P + No C type associated + RecFlag NonRecursive, Not promotable + = K6 :: forall (k::BOX) (a::k). T6 k a + FamilyInstance: none + T7 :: forall (k :: BOX). k -> * -> * + data T7 (k::BOX)@N (a::k)@P b@R + No C type associated + RecFlag NonRecursive, Not promotable + = K7 :: forall (k::BOX) (a::k) b. b -> T7 k a b Stricts: _ + FamilyInstance: none +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] + +==================== Typechecker ==================== + diff --git a/testsuite/tests/deriving/should_compile/Roles13.hs b/testsuite/tests/deriving/should_compile/Roles13.hs new file mode 100644 index 0000000000..70d4c0c7d0 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles13.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- tests axiom roles + +module Roles13 where + +newtype Age = MkAge Int +newtype Wrap a = MkWrap a + +convert :: Wrap Age -> Int +convert (MkWrap (MkAge i)) = i diff --git a/testsuite/tests/deriving/should_compile/Roles13.stderr b/testsuite/tests/deriving/should_compile/Roles13.stderr new file mode 100644 index 0000000000..647e59ba51 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles13.stderr @@ -0,0 +1,20 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 5, types: 9, coercions: 5} + +a :: Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age +[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] +a = \ (ds :: Roles13.Wrap Roles13.Age) -> ds + +Roles13.convert :: Roles13.Wrap Roles13.Age -> GHC.Types.Int +[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] +Roles13.convert = + a + `cast` (<Roles13.Wrap Roles13.Age>_R + -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] + :: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age) + ~# + (Roles13.Wrap Roles13.Age -> GHC.Types.Int)) + + + diff --git a/testsuite/tests/deriving/should_compile/Roles2.hs b/testsuite/tests/deriving/should_compile/Roles2.hs new file mode 100644 index 0000000000..1ead5a4e94 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles2.hs @@ -0,0 +1,9 @@ +module Roles2 where + +import GHC.Ptr + +-- these *must* have certain roles, or things break strangely +-- see TcForeign + +data T1 a = K1 (IO a) +data T2 a = K2 (FunPtr a) diff --git a/testsuite/tests/deriving/should_compile/Roles2.stderr b/testsuite/tests/deriving/should_compile/Roles2.stderr new file mode 100644 index 0000000000..2dcf28e3bf --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles2.stderr @@ -0,0 +1,20 @@ +TYPE SIGNATURES +TYPE CONSTRUCTORS + T1 :: * -> * + data T1 a@R + No C type associated + RecFlag NonRecursive, Not promotable + = K1 :: forall a. (IO a) -> T1 a Stricts: _ + FamilyInstance: none + T2 :: * -> * + data T2 a@R + No C type associated + RecFlag NonRecursive, Not promotable + = K2 :: forall a. (FunPtr a) -> T2 a Stricts: _ + FamilyInstance: none +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] + +==================== Typechecker ==================== + diff --git a/testsuite/tests/deriving/should_compile/Roles3.hs b/testsuite/tests/deriving/should_compile/Roles3.hs new file mode 100644 index 0000000000..4c26f0d986 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles3.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} + +module Roles3 where + +class C1 a where + meth1 :: a -> a + +class C2 a b where + meth2 :: a ~ b => a -> b + +class C3 a b where + type F3 b + meth3 :: a -> F3 b -> F3 b + +type family F4 a + +class C4 a b where + meth4 :: a -> F4 b -> F4 b + +type Syn1 a = F4 a +type Syn2 a = [a]
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_compile/Roles3.stderr b/testsuite/tests/deriving/should_compile/Roles3.stderr new file mode 100644 index 0000000000..1b187f4907 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles3.stderr @@ -0,0 +1,35 @@ +TYPE SIGNATURES +TYPE CONSTRUCTORS + C1 :: * -> Constraint + class C1 a@R + RecFlag NonRecursive + meth1 :: a -> a + C2 :: * -> * -> Constraint + class C2 a@N b@N + RecFlag NonRecursive + meth2 :: (~) * a b -> a -> b + C3 :: * -> * -> Constraint + class C3 a@R b@N + RecFlag NonRecursive + type family F3 b@N :: * + meth3 :: a -> F3 b -> F3 b + C4 :: * -> * -> Constraint + class C4 a@R b@N + RecFlag NonRecursive + meth4 :: a -> F4 b -> F4 b + F4 :: * -> * + type family F4 a@N :: * + Syn1 :: * -> * + type Syn1 a@N = F4 a + Syn2 :: * -> * + type Syn2 a@R = [a] +COERCION AXIOMS + axiom Roles3.NTCo:C1 :: C1 a = a -> a + axiom Roles3.NTCo:C2 :: C2 a b = a ~ b => a -> b + axiom Roles3.NTCo:C3 :: C3 a b = a -> F3 b -> F3 b + axiom Roles3.NTCo:C4 :: C4 a b = a -> F4 b -> F4 b +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] + +==================== Typechecker ==================== + diff --git a/testsuite/tests/deriving/should_compile/Roles4.hs b/testsuite/tests/deriving/should_compile/Roles4.hs new file mode 100644 index 0000000000..32cb65a7df --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles4.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RoleAnnotations #-} + +module Roles4 where + +class C1 a@N where + meth1 :: a -> a + +class C2 a@R where + meth2 :: a -> a + +type Syn1 a@N = [a] + +class C3 a where + meth3 :: a -> Syn1 a + diff --git a/testsuite/tests/deriving/should_compile/Roles4.stderr b/testsuite/tests/deriving/should_compile/Roles4.stderr new file mode 100644 index 0000000000..9969cbca12 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/Roles4.stderr @@ -0,0 +1,25 @@ +TYPE SIGNATURES +TYPE CONSTRUCTORS + C1 :: * -> Constraint + class C1 a@N + RecFlag NonRecursive + meth1 :: a -> a + C2 :: * -> Constraint + class C2 a@R + RecFlag NonRecursive + meth2 :: a -> a + C3 :: * -> Constraint + class C3 a@N + RecFlag NonRecursive + meth3 :: a -> Syn1 a + Syn1 :: * -> * + type Syn1 a@N = [a] +COERCION AXIOMS + axiom Roles4.NTCo:C1 :: C1 a = a -> a + axiom Roles4.NTCo:C2 :: C2 a = a -> a + axiom Roles4.NTCo:C3 :: C3 a = a -> Syn1 a +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] + +==================== Typechecker ==================== + diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 07df602a20..e8fa8fe88d 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -39,4 +39,10 @@ test('T1133', test('T7704', normal, compile, ['']) test('T7710', normal, compile, ['']) -test('AutoDeriveTypeable', normal, compile, [''])
\ No newline at end of file +test('AutoDeriveTypeable', normal, compile, ['']) + +test('Roles1', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles2', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles3', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles4', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques'])
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/Makefile b/testsuite/tests/deriving/should_fail/Makefile index 629e011255..7e68e3840e 100644 --- a/testsuite/tests/deriving/should_fail/Makefile +++ b/testsuite/tests/deriving/should_fail/Makefile @@ -6,8 +6,11 @@ drvfail016: $(RM) -f drvfail016.hi-boot drvfail016.o-boot '$(TEST_HC)' $(TEST_HC_OPTS) -XGeneralizedNewtypeDeriving -c drvfail016.hs-boot; echo $$? -.PHONY: T1133A +.PHONY: T1133A Roles12 T1133A: '$(TEST_HC)' $(TEST_HC_OPTS) -c T1133A.hs-boot -'$(TEST_HC)' $(TEST_HC_OPTS) -c T1133A.hs +Roles12: + '$(TEST_HC)' $(TEST_HC_OPTS) -c Roles12.hs-boot + -'$(TEST_HC)' $(TEST_HC_OPTS) -c Roles12.hs diff --git a/testsuite/tests/deriving/should_fail/Roles10.hs b/testsuite/tests/deriving/should_fail/Roles10.hs new file mode 100644 index 0000000000..af19bfdf31 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles10.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} + +module Roles10 where + +type family F a +type instance F Int = Bool +type instance F Age = Char + +class C a where + meth :: a -> F a + +instance C Int where + meth = (> 0) + +newtype Age = MkAge Int + deriving C
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/Roles10.stderr b/testsuite/tests/deriving/should_fail/Roles10.stderr new file mode 100644 index 0000000000..caf83fc478 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles10.stderr @@ -0,0 +1,7 @@ + +Roles10.hs:16:12: + Can't make a derived instance of ‛C Age’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛C’ is at role N + In the newtype declaration for ‛Age’ diff --git a/testsuite/tests/deriving/should_fail/Roles11.hs b/testsuite/tests/deriving/should_fail/Roles11.hs new file mode 100644 index 0000000000..c95cee798d --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles11.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs, RoleAnnotations #-} + +module Roles11 where + +data T2 a@R where + K2 :: T2 Int + diff --git a/testsuite/tests/deriving/should_fail/Roles11.stderr b/testsuite/tests/deriving/should_fail/Roles11.stderr new file mode 100644 index 0000000000..5a3ad69e53 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles11.stderr @@ -0,0 +1,5 @@ + +Roles11.hs:5:1: + Role mismatch on variable a: + Annotation says R but role N is required + In the data declaration for ‛T2’ diff --git a/testsuite/tests/deriving/should_fail/Roles12.hs b/testsuite/tests/deriving/should_fail/Roles12.hs new file mode 100644 index 0000000000..875d105b78 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles12.hs @@ -0,0 +1,5 @@ +module Roles12 where + +import {-# SOURCE #-} Roles12 + +data T a diff --git a/testsuite/tests/deriving/should_fail/Roles12.hs-boot b/testsuite/tests/deriving/should_fail/Roles12.hs-boot new file mode 100644 index 0000000000..6a708d984a --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles12.hs-boot @@ -0,0 +1,3 @@ +module Roles12 where + +data T a
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/Roles12.stderr b/testsuite/tests/deriving/should_fail/Roles12.stderr new file mode 100644 index 0000000000..e7f9329f6a --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles12.stderr @@ -0,0 +1,12 @@ + +Roles12.hs:5:6: + Type constructor ‛T’ has conflicting definitions in the module and its hs-boot file + Main module: data T a@P + No C type associated + RecFlag Recursive, Promotable + = + FamilyInstance: none + Boot file: abstract(False) T a@R + No C type associated + RecFlag NonRecursive, Not promotable + FamilyInstance: none diff --git a/testsuite/tests/deriving/should_fail/Roles5.hs b/testsuite/tests/deriving/should_fail/Roles5.hs new file mode 100644 index 0000000000..8fe983ccb9 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles5.hs @@ -0,0 +1,5 @@ +module Roles5 where + +data T a@N +class C a@R +type S a@P = Int
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/Roles5.stderr b/testsuite/tests/deriving/should_fail/Roles5.stderr new file mode 100644 index 0000000000..2a58a8a0ed --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles5.stderr @@ -0,0 +1,15 @@ + +Roles5.hs:3:8: + Illegal role annotation + Perhaps you intended to use -XRoleAnnotations + In the data type declaration for ‛T’ + +Roles5.hs:4:9: + Illegal role annotation + Perhaps you intended to use -XRoleAnnotations + In the declaration for class C + +Roles5.hs:5:8: + Illegal role annotation + Perhaps you intended to use -XRoleAnnotations + In the declaration for type synonym ‛S’ diff --git a/testsuite/tests/deriving/should_fail/Roles6.hs b/testsuite/tests/deriving/should_fail/Roles6.hs new file mode 100644 index 0000000000..56f80a1e2b --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles6.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations, TypeFamilies #-} + +module Roles6 where + +type family F a@R diff --git a/testsuite/tests/deriving/should_fail/Roles6.stderr b/testsuite/tests/deriving/should_fail/Roles6.stderr new file mode 100644 index 0000000000..4b89a9e40a --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles6.stderr @@ -0,0 +1,5 @@ + +Roles6.hs:5:1: + Illegal role annotation on variable a; + role annotations are not allowed here + In the family declaration for ‛F’ diff --git a/testsuite/tests/deriving/should_fail/Roles7.hs b/testsuite/tests/deriving/should_fail/Roles7.hs new file mode 100644 index 0000000000..5d62803e3a --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles7.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RoleAnnotations #-} + +module Roles7 where + +bar :: Int@P -> Int +bar = id
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/Roles7.stderr b/testsuite/tests/deriving/should_fail/Roles7.stderr new file mode 100644 index 0000000000..5e527a69f7 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles7.stderr @@ -0,0 +1,4 @@ + +Roles7.hs:5:8: + Illegal role annotation on Int + In the type signature for ‛bar’ diff --git a/testsuite/tests/deriving/should_fail/Roles8.hs b/testsuite/tests/deriving/should_fail/Roles8.hs new file mode 100644 index 0000000000..b05cf5dad4 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles8.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations, GADTs #-} + +module Roles8 where + +data T1 a@P = K1 a diff --git a/testsuite/tests/deriving/should_fail/Roles8.stderr b/testsuite/tests/deriving/should_fail/Roles8.stderr new file mode 100644 index 0000000000..a650a66a30 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles8.stderr @@ -0,0 +1,5 @@ + +Roles8.hs:5:1: + Role mismatch on variable a: + Annotation says P but role R is required + In the data declaration for ‛T1’ diff --git a/testsuite/tests/deriving/should_fail/Roles9.hs b/testsuite/tests/deriving/should_fail/Roles9.hs new file mode 100644 index 0000000000..86d10a3063 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles9.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, RoleAnnotations #-} + +module Roles9 where + +class C a@N where + meth :: a -> a + +instance C Int where + meth = (+ 1) + +newtype Age = MkAge Int + deriving C diff --git a/testsuite/tests/deriving/should_fail/Roles9.stderr b/testsuite/tests/deriving/should_fail/Roles9.stderr new file mode 100644 index 0000000000..611c377935 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/Roles9.stderr @@ -0,0 +1,7 @@ + +Roles9.hs:12:12: + Can't make a derived instance of ‛C Age’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛C’ is at role N + In the newtype declaration for ‛Age’ diff --git a/testsuite/tests/deriving/should_fail/T1496.hs b/testsuite/tests/deriving/should_fail/T1496.hs new file mode 100644 index 0000000000..35675ebd97 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T1496.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} + +module T1496 where + +data family Z :: * -> * + +newtype instance Z Int = ZI Double +newtype instance Z Moo = ZM (Int,Int) + +newtype Moo = Moo Int deriving(IsInt) +class IsInt t where + isInt :: c Int -> c t + +instance IsInt Int where isInt = id + +main = case isInt (ZI 4.0) of ZM tu -> print tu
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/T1496.stderr b/testsuite/tests/deriving/should_fail/T1496.stderr new file mode 100644 index 0000000000..32a67a6e46 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T1496.stderr @@ -0,0 +1,7 @@ + +T1496.hs:10:32: + Can't make a derived instance of ‛IsInt Moo’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛IsInt’ is at role N + In the newtype declaration for ‛Moo’ diff --git a/testsuite/tests/deriving/should_fail/T2721.stderr b/testsuite/tests/deriving/should_fail/T2721.stderr index 64e93c3d12..375c8a4247 100644 --- a/testsuite/tests/deriving/should_fail/T2721.stderr +++ b/testsuite/tests/deriving/should_fail/T2721.stderr @@ -3,4 +3,6 @@ T2721.hs:15:28: Can't make a derived instance of ‛C N’ (even with cunning newtype deriving): the class has associated types + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛C’ is at role N In the newtype declaration for ‛N’ diff --git a/testsuite/tests/deriving/should_fail/T4846.hs b/testsuite/tests/deriving/should_fail/T4846.hs new file mode 100755 index 0000000000..66621c04ee --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T4846.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, StandaloneDeriving, GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
+
+module Main where
+
+import Data.Typeable
+
+data Expr a where
+ Lit :: Typeable a => a -> Expr a
+
+class A a where
+ mk :: a
+
+class (Typeable a, A a) => B a where
+ mkExpr :: Expr a
+ mkExpr = Lit mk
+
+-- dfunAE
+instance B a => A (Expr a) where
+ mk = mkExpr
+
+-- dfunAB
+instance A Bool where
+ mk = True
+
+newtype BOOL = BOOL Bool
+ deriving (Typeable, A)
+
+instance B Bool
+deriving instance B BOOL --dfunBB
+
+showType :: forall a . Expr a -> String
+showType (Lit _) = show (typeOf (undefined :: a))
+
+test1 = showType (mk :: Expr BOOL) -- Prints "Bool" (wrong?)
+test2 = showType (Lit mk :: Expr BOOL) -- Prints "Main.BOOL" (correct)
+
+main = do { print test1; print test2 }
diff --git a/testsuite/tests/deriving/should_fail/T4846.stderr b/testsuite/tests/deriving/should_fail/T4846.stderr new file mode 100644 index 0000000000..22556b0b6c --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T4846.stderr @@ -0,0 +1,7 @@ + +T4846.hs:29:1: + Can't make a derived instance of ‛B BOOL’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛B’ is at role N + In the stand-alone deriving instance for ‛B BOOL’ diff --git a/testsuite/tests/deriving/should_fail/T7148.hs b/testsuite/tests/deriving/should_fail/T7148.hs new file mode 100644 index 0000000000..1f91286e05 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T7148.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} + +module T7148 where + +data SameType a b where + Refl :: SameType a a + +coerce :: SameType a b -> a -> b +coerce Refl = id + +trans :: SameType a b -> SameType b c -> SameType a c +trans Refl Refl = Refl + +sameUnit :: SameType () () +sameUnit = Refl + + +class IsoUnit a where + iso1 :: SameType () b -> SameType a b + iso2 :: SameType b () -> SameType b a + +instance IsoUnit () where + iso1 = id + iso2 = id + + +newtype Tagged a b = Tagged b deriving IsoUnit + +sameTagged :: SameType (Tagged a b) (Tagged a' b') -> SameType a a' +sameTagged Refl = Refl + +unsafe' :: SameType (Tagged a ()) (Tagged a' ()) +unsafe' = (iso1 sameUnit) `trans` (iso2 sameUnit) + +unsafe :: SameType a b +unsafe = sameTagged unsafe' + +--once again inferred type is a -> b +unsafeCoerce = coerce unsafe
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/T7148.stderr b/testsuite/tests/deriving/should_fail/T7148.stderr new file mode 100644 index 0000000000..dcee25ff5f --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T7148.stderr @@ -0,0 +1,7 @@ + +T7148.hs:27:40: + Can't make a derived instance of ‛IsoUnit (Tagged a b)’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛IsoUnit’ is at role N + In the newtype declaration for ‛Tagged’ diff --git a/testsuite/tests/deriving/should_fail/T7148a.hs b/testsuite/tests/deriving/should_fail/T7148a.hs new file mode 100644 index 0000000000..6441058b24 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T7148a.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, + GeneralizedNewtypeDeriving #-} + +module T7148a where + +import Control.Monad.ST +data Proxy a = Proxy +type family Result a b + +class Convert a where + coerce :: Proxy b -> a -> Result a b + +newtype SAFE a = SAFE a +type instance Result (SAFE a) b = a + +instance Convert (SAFE a) where + coerce _ (SAFE a) = a + +newtype IS_NO_LONGER a = IS_NO_LONGER a deriving Convert +type instance Result (IS_NO_LONGER a) b = b + +--infered type is +unsafeCoerce :: forall a b. a -> b +unsafeCoerce = coerce (Proxy :: Proxy b) . IS_NO_LONGER . SAFE + +--use it safely +id' :: a -> a +id' = unsafeCoerce + +--segfault (with high probability) +crash :: segfault +crash = unsafeCoerce . tail . tail . tail . unsafeCoerce $ True + + +--time for side effects +unsafePerformIO :: IO a -> a +unsafePerformIO x = runST $ unsafeCoerce x
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/T7148a.stderr b/testsuite/tests/deriving/should_fail/T7148a.stderr new file mode 100644 index 0000000000..f2a938c0a7 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T7148a.stderr @@ -0,0 +1,7 @@ + +T7148a.hs:19:50: + Can't make a derived instance of ‛Convert (IS_NO_LONGER a)’ + (even with cunning newtype deriving): + it is not type-safe to use GeneralizedNewtypeDeriving on this class; + the last parameter of ‛Convert’ is at role N + In the newtype declaration for ‛IS_NO_LONGER’ diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index c2d304ee19..610f1181fe 100644 --- a/testsuite/tests/deriving/should_fail/all.T +++ b/testsuite/tests/deriving/should_fail/all.T @@ -41,3 +41,18 @@ test('T1133A', ['$MAKE --no-print-directory -s T1133A']) test('T5863a', normal, compile_fail, ['']) test('T7959', normal, compile_fail, ['']) + +test('Roles5', normal, compile_fail, ['']) +test('Roles6', normal, compile_fail, ['']) +test('Roles7', normal, compile_fail, ['']) +test('Roles8', normal, compile_fail, ['']) +test('Roles9', normal, compile_fail, ['']) +test('Roles10', normal, compile_fail, ['']) +test('Roles11', normal, compile_fail, ['']) +test('Roles12', + extra_clean(['Roles12.o-boot', 'Roles12.hi-boot']), + run_command, ['$MAKE --no-print-directory -s Roles12']) +test('T1496', normal, compile_fail, ['']) +test('T4846', normal, compile_fail, ['']) +test('T7148', normal, compile_fail, ['']) +test('T7148a', normal, compile_fail, ['']) |