Add some tests for the new generic deriving mechanism.

16 files changed, 221 insertions, 0 deletions

diff --git a/testsuite/tests/ghc-regress/generics/GEq/GEq.hs b/testsuite/tests/ghc-regress/generics/GEq/GEq.hs
new file mode 100644
index 0000000000..a878617e26
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/GEq/GEq.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE TypeOperators, Generics, FlexibleContexts, FlexibleInstances #-}
+
+module GEq where
+
+import GHC.Generics
+
+class GEq' f where
+  geq' :: f a -> f a -> Bool
+
+instance GEq' U1 where
+  geq' _ _ = True
+
+instance GEq' (K1 P c) where
+  geq' (K1 a) (K1 b) = undefined
+
+instance (GEq c) => GEq' (K1 R c) where
+  geq' (K1 a) (K1 b) = geq a b
+
+-- No instances for P or Rec because geq is only applicable to types of kind *
+
+instance (GEq' a) => GEq' (M1 i c a) where
+  geq' (M1 a) (M1 b) = geq' a b
+
+instance (GEq' a, GEq' b) => GEq' (a :+: b) where
+  geq' (L1 a) (L1 b) = geq' a b
+  geq' (R1 a) (R1 b) = geq' a b
+  geq' _      _      = False
+
+instance (GEq' a, GEq' b) => GEq' (a :*: b) where
+  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
+
+
+class GEq a where 
+  geq :: a -> a -> Bool
+  default geq :: (Representable0 a, GEq' (Rep0 a)) => a -> a -> Bool
+  geq x y = geq' (from0 x) (from0 y)
+
+
+-- Base types instances (ad-hoc)
+instance GEq Char   where geq = (==)
+instance GEq Int    where geq = (==)
+instance GEq Float  where geq = (==)
+{-
+-- Generic instances
+instance (GEq a) => GEq (Maybe a)
+instance (GEq a) => GEq [a]
+-}
diff --git a/testsuite/tests/ghc-regress/generics/GEq/GEq1.stdout b/testsuite/tests/ghc-regress/generics/GEq/GEq1.stdout
new file mode 100644
index 0000000000..db029dea2a
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/GEq/GEq1.stdout
@@ -0,0 +1,3 @@
+False
+False
+True
diff --git a/testsuite/tests/ghc-regress/generics/GEq/Main.hs b/testsuite/tests/ghc-regress/generics/GEq/Main.hs
new file mode 100644
index 0000000000..7cb9f95b85
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/GEq/Main.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeOperators, Generics #-}
+
+module Main where
+
+import GHC.Generics hiding (C, D)
+import GEq
+
+-- We should be able to generate a generic representation for these types
+
+data C = C0 | C1
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+
+-- Example values
+c0 = C0
+c1 = C1
+
+d0 :: D Char
+d0 = D0
+d1 = D1 'p' D0
+
+-- Generic instances
+instance            GEq C
+instance (GEq a) => GEq (D a)
+
+-- Tests
+teq0 = geq c0 c1
+teq1 = geq d0 d1
+teq2 = geq d0 d0
+
+main = mapM_ print [teq0, teq1, teq2]
diff --git a/testsuite/tests/ghc-regress/generics/GEq/Makefile b/testsuite/tests/ghc-regress/generics/GEq/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/GEq/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/generics/GEq/test.T b/testsuite/tests/ghc-regress/generics/GEq/test.T
new file mode 100644
index 0000000000..ae2cc994bb
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/GEq/test.T
@@ -0,0 +1,3 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GEq1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
diff --git a/testsuite/tests/ghc-regress/generics/Makefile b/testsuite/tests/ghc-regress/generics/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/generics/Uniplate/Main.hs b/testsuite/tests/ghc-regress/generics/Uniplate/Main.hs
new file mode 100644
index 0000000000..90461d8145
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Uniplate/Main.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE Generics #-}
+
+module Main where
+
+import GHC.Generics
+import Uniplate
+
+
+data Tree     = Leaf | Node Int Tree Tree deriving Show
+data Pair a b = Pair a b                  deriving Show
+
+instance Uniplate Tree
+instance Uniplate (Pair a b)
+
+-- Tests
+t1 = children ('p')
+t2 = children (Pair "abc" (Pair "abc" 2))
+t3 = children (Node 2 Leaf Leaf)
+
+main = print (t1, t2, t3)
diff --git a/testsuite/tests/ghc-regress/generics/Uniplate/Makefile b/testsuite/tests/ghc-regress/generics/Uniplate/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Uniplate/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate.hs b/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate.hs
new file mode 100644
index 0000000000..85de94b12f
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}

+{-# LANGUAGE TypeSynonymInstances       #-}

+{-# LANGUAGE FlexibleInstances          #-}

+{-# LANGUAGE FlexibleContexts           #-}

+{-# LANGUAGE TypeOperators              #-}

+{-# LANGUAGE Generics                   #-}

+{-# LANGUAGE IncoherentInstances        #-} -- necessary, unfortunately

+

+module Uniplate where

+

+import GHC.Generics

+

+--------------------------------------------------------------------------------

+-- Generic Uniplate

+--------------------------------------------------------------------------------

+

+class Uniplate' f b where

+  children' :: f a -> [b]

+

+instance Uniplate' U1 a where

+  children' U1 = []

+

+instance Uniplate' (K1 i a) a where

+  children' (K1 a) = [a]

+

+instance Uniplate' (K1 i a) b where

+  children' (K1 _) = []

+

+instance (Uniplate' f b) => Uniplate' (M1 i c f) b where

+  children' (M1 a) = children' a

+

+instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where

+  children' (L1 a) = children' a

+  children' (R1 a) = children' a

+

+instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where

+  children' (a :*: b) = children' a ++ children' b 

+

+

+class Uniplate a where 

+  children :: a -> [a]

+  default children :: (Representable0 a, Uniplate' (Rep0 a) a) => a -> [a]

+  children = children' . from0

+

+

+-- Base types instances

+instance Uniplate Char  where children _ = []

+instance Uniplate Int   where children _ = []

+instance Uniplate Float where children _ = []

+

+instance Uniplate [a] where

+  children []    = []

+  children (_:t) = [t]

diff --git a/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate1.stdout b/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate1.stdout
new file mode 100644
index 0000000000..f560e40162
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Uniplate/Uniplate1.stdout
@@ -0,0 +1 @@
+("",[],[Leaf,Leaf])
diff --git a/testsuite/tests/ghc-regress/generics/Uniplate/test.T b/testsuite/tests/ghc-regress/generics/Uniplate/test.T
new file mode 100644
index 0000000000..100c12a9c0
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/Uniplate/test.T
@@ -0,0 +1,3 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('Uniplate1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
diff --git a/testsuite/tests/ghc-regress/generics/all.T b/testsuite/tests/ghc-regress/generics/all.T
new file mode 100644
index 0000000000..9c91903f1f
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/all.T
@@ -0,0 +1,7 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('canDoRep0', normal, compile, [''])
+
+test('cannotDoRep0', normal, compile_fail, [''])
+test('cannotDoRep1', normal, compile_fail, [''])
+test('cannotDoRep2', normal, compile_fail, [''])
diff --git a/testsuite/tests/ghc-regress/generics/canDoRep0.hs b/testsuite/tests/ghc-regress/generics/canDoRep0.hs
new file mode 100644
index 0000000000..59e6c97ccb
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/canDoRep0.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE Generics #-}
+
+module ShouldCompile0 where
+
+-- We should be able to generate a generic representation for these types
+data A
+
+data B a
+
+data C = C0 | C1
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+
+data E a = E0 a (E a) (D a)
diff --git a/testsuite/tests/ghc-regress/generics/cannotDoRep0.hs b/testsuite/tests/ghc-regress/generics/cannotDoRep0.hs
new file mode 100644
index 0000000000..97ade74989
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/cannotDoRep0.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DeriveRepresentable        #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+
+module ShouldFail0 where
+
+import GHC.Generics
+
+-- We do not support existential quantification
+data Dynamic = forall a. Dynamic a deriving Representable0
diff --git a/testsuite/tests/ghc-regress/generics/cannotDoRep1.hs b/testsuite/tests/ghc-regress/generics/cannotDoRep1.hs
new file mode 100644
index 0000000000..49d7218974
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/cannotDoRep1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveRepresentable #-}
+
+module ShouldFail1 where
+
+import GHC.Generics
+
+-- We do not support datatypes with context
+data (Show a) => Context a = Context a deriving Representable0
diff --git a/testsuite/tests/ghc-regress/generics/cannotDoRep2.hs b/testsuite/tests/ghc-regress/generics/cannotDoRep2.hs
new file mode 100644
index 0000000000..05161ab302
--- /dev/null
+++ b/testsuite/tests/ghc-regress/generics/cannotDoRep2.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveRepresentable #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE GADTs               #-}
+
+module ShouldFail2 where
+
+import GHC.Generics
+
+-- We do not support GADTs
+data Term a where
+  Int :: Term Int
+
+deriving instance Representable0 (Term a)