summaryrefslogtreecommitdiff
path: root/testsuite/tests
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests')
-rw-r--r--testsuite/tests/generics/GEq/GEq1.hs33
-rw-r--r--testsuite/tests/generics/GEq/GEq1.stdout2
-rw-r--r--testsuite/tests/generics/GEq/GEq1A.hs22
-rw-r--r--testsuite/tests/generics/GShow/GShow.hs32
-rw-r--r--testsuite/tests/generics/GShow/GShow1.stdout1
-rw-r--r--testsuite/tests/generics/GShow/Main.hs10
-rw-r--r--testsuite/tests/generics/T8468.stderr2
7 files changed, 79 insertions, 23 deletions
diff --git a/testsuite/tests/generics/GEq/GEq1.hs b/testsuite/tests/generics/GEq/GEq1.hs
index 164535cddb..d6ca0b057e 100644
--- a/testsuite/tests/generics/GEq/GEq1.hs
+++ b/testsuite/tests/generics/GEq/GEq1.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies,
+ FlexibleInstances, MagicHash #-}
module Main where
+import GHC.Exts
import GHC.Generics hiding (C, D)
import GEq1A
@@ -20,6 +22,13 @@ data family F a b :: * -> *
data instance F Int b c = F b Int c
deriving Generic
+data U a = U a Addr# Char# Double# Float# Int# Word#
+ deriving Generic
+
+data family UF a b :: * -> *
+data instance UF Int b c = UF b c Addr# Char# Double# Float# Int# Word#
+ deriving Generic
+
-- Example values
c0 = C0
c1 = C1
@@ -35,17 +44,27 @@ f1 :: F Int Float Char
f1 = F 0.0 3 'h'
f2 = F 0.0 4 'h'
+u0 :: U Int
+u0 = U 1 "1"# '1'# 1.0## 1.0# 1# 1##
+
+uf0 :: UF Int Int Int
+uf0 = UF 2 2 "1"# '2'# 2.0## 2.0# 2# 2##
+
-- Generic instances
instance GEq C
instance (GEq a) => GEq (D a)
instance (GEq a, GEq b) => GEq (a :**: b)
instance (GEq b, GEq c) => GEq (F Int b c)
+instance (GEq a) => GEq (U a)
+instance (GEq b, GEq c) => GEq (UF Int b c)
-- Tests
-teq0 = geq c0 c1
-teq1 = geq d0 d1
-teq2 = geq d0 d0
-teq3 = geq p1 p1
-teq4 = geq f1 f2
+teq0 = geq c0 c1
+teq1 = geq d0 d1
+teq2 = geq d0 d0
+teq3 = geq p1 p1
+teq4 = geq f1 f2
+teq5 = geq u0 u0
+teq6 = geq uf0 uf0
-main = mapM_ print [teq0, teq1, teq2, teq3, teq4]
+main = mapM_ print [teq0, teq1, teq2, teq3, teq4, teq5, teq6]
diff --git a/testsuite/tests/generics/GEq/GEq1.stdout b/testsuite/tests/generics/GEq/GEq1.stdout
index 3ce45b831d..e590e50cd2 100644
--- a/testsuite/tests/generics/GEq/GEq1.stdout
+++ b/testsuite/tests/generics/GEq/GEq1.stdout
@@ -3,3 +3,5 @@ False
True
True
False
+True
+True
diff --git a/testsuite/tests/generics/GEq/GEq1A.hs b/testsuite/tests/generics/GEq/GEq1A.hs
index 7bdfbebe54..9a91e8040b 100644
--- a/testsuite/tests/generics/GEq/GEq1A.hs
+++ b/testsuite/tests/generics/GEq/GEq1A.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, FlexibleInstances #-}
+{-# LANGUAGE TypeOperators, DefaultSignatures,
+ FlexibleContexts, FlexibleInstances, MagicHash #-}
module GEq1A where
+import GHC.Exts
import GHC.Generics
class GEq' f where
@@ -26,13 +28,25 @@ instance (GEq' a, GEq' b) => GEq' (a :+: b) where
instance (GEq' a, GEq' b) => GEq' (a :*: b) where
geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
-
-class GEq a where
+-- Unboxed types
+instance GEq' UAddr where
+ geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)
+instance GEq' UChar where
+ geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)
+instance GEq' UDouble where
+ geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)
+instance GEq' UFloat where
+ geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)
+instance GEq' UInt where
+ geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)
+instance GEq' UWord where
+ geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)
+
+class GEq a where
geq :: a -> a -> Bool
default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
geq x y = geq' (from x) (from y)
-
-- Base types instances (ad-hoc)
instance GEq Char where geq = (==)
instance GEq Int where geq = (==)
diff --git a/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs
index 3c8f2591ef..6cdda282d8 100644
--- a/testsuite/tests/generics/GShow/GShow.hs
+++ b/testsuite/tests/generics/GShow/GShow.hs
@@ -5,13 +5,14 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE IncoherentInstances #-} -- :-/
{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE MagicHash #-}
module GShow (
-- * Generic show class
GShow(..)
) where
-
+import GHC.Exts
import GHC.Generics
--------------------------------------------------------------------------------
@@ -36,10 +37,10 @@ instance (GShow c) => GShow' (K1 i c) where
-- No instances for P or Rec because gshow is only applicable to types of kind *
instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
- gshowsPrec' _ n c@(M1 x) =
+ gshowsPrec' _ n c@(M1 x) =
case (fixity, conIsTuple c) of
- (Prefix,False) -> showParen (n > 10 && not (isNullary x))
- ( showString (conName c)
+ (Prefix,False) -> showParen (n > 10 && not (isNullary x))
+ ( showString (conName c)
. if (isNullary x) then id else showChar ' '
. showBraces t (gshowsPrec' t 10 x))
(Prefix,True) -> showParen (n > 10) (showBraces t (gshowsPrec' t 10 x))
@@ -58,7 +59,7 @@ instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
conIsTuple c = case conName c of
('(':',':_) -> True
otherwise -> False
-
+
isNullary (M1 x) = isNullary x
instance (Selector s, GShow' a) => GShow' (M1 S s a) where
@@ -85,12 +86,23 @@ instance (GShow' a, GShow' b) => GShow' (a :*: b) where
gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b
gshowsPrec' t@Pref n (a :*: b) =
gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b
-
+
-- If we have a product then it is not a nullary constructor
isNullary _ = False
-
-class GShow a where
+-- Unboxed instances
+instance GShow' UChar where
+ gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'
+instance GShow' UDouble where
+ gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"
+instance GShow' UFloat where
+ gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#'
+instance GShow' UInt where
+ gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#'
+instance GShow' UWord where
+ gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"
+
+class GShow a where
gshowsPrec :: Int -> a -> ShowS
default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS
gshowsPrec n = gshowsPrec' Pref n . from
@@ -100,13 +112,15 @@ class GShow a where
gshow :: a -> String
gshow x = gshows x ""
-
+
-- Base types instances
instance GShow Char where gshowsPrec = showsPrec
+instance GShow Double where gshowsPrec = showsPrec
instance GShow Int where gshowsPrec = showsPrec
instance GShow Float where gshowsPrec = showsPrec
instance GShow String where gshowsPrec = showsPrec
+instance GShow Word where gshowsPrec = showsPrec
instance GShow Bool where gshowsPrec = showsPrec
intersperse :: a -> [a] -> [a]
diff --git a/testsuite/tests/generics/GShow/GShow1.stdout b/testsuite/tests/generics/GShow/GShow1.stdout
index 6109e446a5..71e1299245 100644
--- a/testsuite/tests/generics/GShow/GShow1.stdout
+++ b/testsuite/tests/generics/GShow/GShow1.stdout
@@ -1,3 +1,4 @@
D0
D1 {d11 = Just 'p', d12 = D0}
D1 {d11 = (3,0.14), d12 = D0}
+U (1) ('1'#) (-1.0##) (-1.0#) (-1#) (1##)
diff --git a/testsuite/tests/generics/GShow/Main.hs b/testsuite/tests/generics/GShow/Main.hs
index 81768ed647..952602e54d 100644
--- a/testsuite/tests/generics/GShow/Main.hs
+++ b/testsuite/tests/generics/GShow/Main.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, MagicHash #-}
module Main where
+import GHC.Exts
import GHC.Generics hiding (C, D)
import GShow
-- We should be able to generate a generic representation for these types
data D a = D0 | D1 { d11 :: a, d12 :: (D a) } deriving Generic
+data U a = U a Char# Double# Float# Int# Word# deriving Generic
-- Example values
d0 :: D Char
@@ -16,8 +18,12 @@ d1 = D1 (Just 'p') D0
d2 :: D (Int,Float)
d2 = D1 (3,0.14) D0
+u0 :: U Int
+u0 = U 1 '1'# -1.0## -1.0# -1# 1##
+
-- Generic instances
instance (GShow a) => GShow (D a)
+instance (GShow a) => GShow (U a)
-- Tests
-main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2]
+main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2, gshow u0]
diff --git a/testsuite/tests/generics/T8468.stderr b/testsuite/tests/generics/T8468.stderr
index 62536cec69..aaf68b9d5a 100644
--- a/testsuite/tests/generics/T8468.stderr
+++ b/testsuite/tests/generics/T8468.stderr
@@ -1,5 +1,5 @@
T8468.hs:6:42:
Can't make a derived instance of ‘Generic1 Array’:
- Array must not have unlifted or polymorphic arguments
+ Array must not have exotic unlifted or polymorphic arguments
In the data declaration for ‘Array’
View Lorry Controller Status