Add tests for deriving Generic1

Most of these tests were written by Nicolas Frisby.

5 files changed, 88 insertions, 0 deletions

diff --git a/testsuite/tests/generics/GFunctor/GFunctor.hs b/testsuite/tests/generics/GFunctor/GFunctor.hs
new file mode 100644
index 0000000000..0044339986
--- /dev/null
+++ b/testsuite/tests/generics/GFunctor/GFunctor.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE DefaultSignatures          #-}
+
+module GFunctor (
+  -- * Generic Functor class
+    GFunctor(..)
+  ) where
+
+
+import GHC.Generics
+
+--------------------------------------------------------------------------------
+-- Generic fmap
+--------------------------------------------------------------------------------
+
+class GFunctor' f where
+  gmap' :: (a -> b) -> f a -> f b
+
+instance GFunctor' U1 where
+  gmap' _ U1 = U1
+
+instance GFunctor' Par1 where
+  gmap' f (Par1 a) = Par1 (f a)
+
+instance GFunctor' (K1 i c) where
+  gmap' _ (K1 a) = K1 a
+
+instance (GFunctor f) => GFunctor' (Rec1 f) where
+  gmap' f (Rec1 a) = Rec1 (gmap f a)
+
+instance (GFunctor' f) => GFunctor' (M1 i c f) where
+  gmap' f (M1 a) = M1 (gmap' f a)
+
+instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where
+  gmap' f (L1 a) = L1 (gmap' f a)
+  gmap' f (R1 a) = R1 (gmap' f a)
+
+instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where
+  gmap' f (a :*: b) = gmap' f a :*: gmap' f b
+
+instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where
+  gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)
+
+
+class GFunctor f where
+  gmap :: (a -> b) -> f a -> f b
+  default gmap :: (Generic1 f, GFunctor' (Rep1 f))
+               => (a -> b) -> f a -> f b
+  gmap f = to1 . gmap' f . from1
+
+-- Base types instances
+instance GFunctor Maybe
+instance GFunctor []
diff --git a/testsuite/tests/generics/GFunctor/GFunctor1.stdout b/testsuite/tests/generics/GFunctor/GFunctor1.stdout
new file mode 100644
index 0000000000..966a02092e
--- /dev/null
+++ b/testsuite/tests/generics/GFunctor/GFunctor1.stdout
@@ -0,0 +1 @@
+(D0,D1 {d11 = 'q', d12 = D0},D1 {d11 = 3.14, d12 = D0})
diff --git a/testsuite/tests/generics/GFunctor/Main.hs b/testsuite/tests/generics/GFunctor/Main.hs
new file mode 100644
index 0000000000..7d0a3df636
--- /dev/null
+++ b/testsuite/tests/generics/GFunctor/Main.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+import GHC.Generics hiding (C, D)
+import GFunctor
+
+-- We should be able to generate a generic representation for these types
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+  deriving (Show, Generic, Generic1)
+
+-- Example values
+d0 :: D Char
+d0 = D0
+d1 = D1 (Just 'p') D0
+
+d2 :: (Fractional a) => D (a,a)
+d2 = D1 (3,0.14) D0
+
+-- Generic instances
+instance GFunctor D
+
+-- Tests
+main = print ( gmap undefined d0 :: D ()
+             , gmap (const 'q') d1
+             , gmap (\(a,b) -> a + b) d2 :: D Float)
diff --git a/testsuite/tests/generics/GFunctor/Makefile b/testsuite/tests/generics/GFunctor/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/generics/GFunctor/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/generics/GFunctor/test.T b/testsuite/tests/generics/GFunctor/test.T
new file mode 100644
index 0000000000..7018d8ffed
--- /dev/null
+++ b/testsuite/tests/generics/GFunctor/test.T
@@ -0,0 +1,4 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GFunctor1', extra_clean(['GFunctor.hi', 'GFunctor.o', 'Main.hi', 'Main.o']),
+     multimod_compile_and_run, ['Main', ''])
\ No newline at end of file