Make GHC generics capable of handling unboxed types

This adds a data family (`URec`) and six data family instances (`UAddr`,
`UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord`) which a `deriving
Generic(1)` clause will generate if it sees `Addr#`, `Char#`, `Double#`,
`Float#`, `Int#`, or `Word#`, respectively. The programmer can then
provide instances for these data family instances to provide custom
implementations for unboxed types, similar to how derived `Eq`, `Ord`,
and `Show` instances currently special-case unboxed types.

Fixes #10868.

Test Plan: ./validate

Reviewers: goldfire, dreixel, bgamari, austin, hvr, kosmikus

Reviewed By: dreixel, kosmikus

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1239

GHC Trac Issues: #10868

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’