summaryrefslogtreecommitdiff
path: root/testsuite/tests/generics
diff options
context:
space:
mode:
authorDavid Terei <davidterei@gmail.com>2011-07-20 11:09:03 -0700
committerDavid Terei <davidterei@gmail.com>2011-07-20 11:26:35 -0700
commit16514f272fb42af6e9c7674a9bd6c9dce369231f (patch)
treee4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/generics
parentebd422aed41048476aa61dd4c520d43becd78682 (diff)
downloadhaskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/generics')
-rw-r--r--testsuite/tests/generics/GEq/GEq.hs44
-rw-r--r--testsuite/tests/generics/GEq/GEq1.stdout4
-rw-r--r--testsuite/tests/generics/GEq/GEq2.hs78
-rw-r--r--testsuite/tests/generics/GEq/GEq2.stdout4
-rw-r--r--testsuite/tests/generics/GEq/Main.hs41
-rw-r--r--testsuite/tests/generics/GEq/Makefile3
-rw-r--r--testsuite/tests/generics/GEq/test.T4
-rw-r--r--testsuite/tests/generics/GShow/GShow.hs124
-rw-r--r--testsuite/tests/generics/GShow/GShow1.stdout3
-rw-r--r--testsuite/tests/generics/GShow/Main.hs23
-rw-r--r--testsuite/tests/generics/GShow/Makefile3
-rw-r--r--testsuite/tests/generics/GShow/test.T3
-rw-r--r--testsuite/tests/generics/GenCanDoRep0.hs23
-rw-r--r--testsuite/tests/generics/GenCannotDoRep0.hs9
-rw-r--r--testsuite/tests/generics/GenCannotDoRep0.stderr5
-rw-r--r--testsuite/tests/generics/GenCannotDoRep1.hs8
-rw-r--r--testsuite/tests/generics/GenCannotDoRep1.stderr8
-rw-r--r--testsuite/tests/generics/GenCannotDoRep2.hs13
-rw-r--r--testsuite/tests/generics/GenCannotDoRep2.stderr5
-rw-r--r--testsuite/tests/generics/GenDeprecated.stderr3
-rw-r--r--testsuite/tests/generics/GenShouldFail0.hs11
-rw-r--r--testsuite/tests/generics/GenShouldFail0.stderr5
-rw-r--r--testsuite/tests/generics/Makefile3
-rw-r--r--testsuite/tests/generics/Uniplate/GUniplate.hs53
-rw-r--r--testsuite/tests/generics/Uniplate/GUniplate1.stdout1
-rw-r--r--testsuite/tests/generics/Uniplate/Main.hs20
-rw-r--r--testsuite/tests/generics/Uniplate/Makefile3
-rw-r--r--testsuite/tests/generics/Uniplate/test.T3
-rw-r--r--testsuite/tests/generics/all.T8
29 files changed, 515 insertions, 0 deletions
diff --git a/testsuite/tests/generics/GEq/GEq.hs b/testsuite/tests/generics/GEq/GEq.hs
new file mode 100644
index 0000000000..54caad34e5
--- /dev/null
+++ b/testsuite/tests/generics/GEq/GEq.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TypeOperators, DefaultSignatures, 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 c) => GEq' (K1 i 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 :: (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 = (==)
+instance GEq Float where geq = (==)
+{-
+-- Generic instances
+instance (GEq a) => GEq (Maybe a)
+instance (GEq a) => GEq [a]
+-}
diff --git a/testsuite/tests/generics/GEq/GEq1.stdout b/testsuite/tests/generics/GEq/GEq1.stdout
new file mode 100644
index 0000000000..a7f0546170
--- /dev/null
+++ b/testsuite/tests/generics/GEq/GEq1.stdout
@@ -0,0 +1,4 @@
+False
+False
+True
+True
diff --git a/testsuite/tests/generics/GEq/GEq2.hs b/testsuite/tests/generics/GEq/GEq2.hs
new file mode 100644
index 0000000000..ac825aa71f
--- /dev/null
+++ b/testsuite/tests/generics/GEq/GEq2.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleInstances, DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Main where
+
+import GHC.Generics hiding (C, D)
+
+class GEq' f where
+ geq' :: f a -> f a -> Bool
+
+instance GEq' U1 where
+ geq' _ _ = True
+
+instance (GEq c) => GEq' (K1 i 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 :: (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 = (==)
+instance GEq Float where geq = (==)
+{-
+-- Generic instances
+instance (GEq a) => GEq (Maybe a)
+instance (GEq a) => GEq [a]
+-}
+
+data C = C0 | C1
+ deriving Generic
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+ deriving Generic
+
+data (:**:) a b = a :**: b
+ deriving Generic
+
+-- Example values
+c0 = C0
+c1 = C1
+
+d0 :: D Char
+d0 = D0
+d1 = D1 'p' D0
+
+p1 :: Int :**: Char
+p1 = 3 :**: 'p'
+
+-- Generic instances
+instance GEq C
+instance (GEq a) => GEq (D a)
+instance (GEq a, GEq b) => GEq (a :**: b)
+
+-- Tests
+teq0 = geq c0 c1
+teq1 = geq d0 d1
+teq2 = geq d0 d0
+teq3 = geq p1 p1
+
+main = mapM_ print [teq0, teq1, teq2, teq3]
diff --git a/testsuite/tests/generics/GEq/GEq2.stdout b/testsuite/tests/generics/GEq/GEq2.stdout
new file mode 100644
index 0000000000..a7f0546170
--- /dev/null
+++ b/testsuite/tests/generics/GEq/GEq2.stdout
@@ -0,0 +1,4 @@
+False
+False
+True
+True
diff --git a/testsuite/tests/generics/GEq/Main.hs b/testsuite/tests/generics/GEq/Main.hs
new file mode 100644
index 0000000000..bc1fbd5e55
--- /dev/null
+++ b/testsuite/tests/generics/GEq/Main.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeOperators, DeriveGeneric #-}
+
+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
+ deriving Generic
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+ deriving Generic
+
+data (:**:) a b = a :**: b
+ deriving Generic
+
+-- Example values
+c0 = C0
+c1 = C1
+
+d0 :: D Char
+d0 = D0
+d1 = D1 'p' D0
+
+p1 :: Int :**: Char
+p1 = 3 :**: 'p'
+
+-- Generic instances
+instance GEq C
+instance (GEq a) => GEq (D a)
+instance (GEq a, GEq b) => GEq (a :**: b)
+
+-- Tests
+teq0 = geq c0 c1
+teq1 = geq d0 d1
+teq2 = geq d0 d0
+teq3 = geq p1 p1
+
+main = mapM_ print [teq0, teq1, teq2, teq3]
diff --git a/testsuite/tests/generics/GEq/Makefile b/testsuite/tests/generics/GEq/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/generics/GEq/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/generics/GEq/test.T b/testsuite/tests/generics/GEq/test.T
new file mode 100644
index 0000000000..363cb48212
--- /dev/null
+++ b/testsuite/tests/generics/GEq/test.T
@@ -0,0 +1,4 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GEq1', normal, multimod_compile_and_run, ['Main', ''])
+test('GEq2', normal, multimod_compile_and_run, ['GEq2', '']) \ No newline at end of file
diff --git a/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs
new file mode 100644
index 0000000000..3c8f2591ef
--- /dev/null
+++ b/testsuite/tests/generics/GShow/GShow.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE IncoherentInstances #-} -- :-/
+{-# LANGUAGE DefaultSignatures #-}
+
+module GShow (
+ -- * Generic show class
+ GShow(..)
+ ) where
+
+
+import GHC.Generics
+
+--------------------------------------------------------------------------------
+-- Generic show
+--------------------------------------------------------------------------------
+
+data Type = Rec | Tup | Pref | Inf String
+
+class GShow' f where
+ gshowsPrec' :: Type -> Int -> f a -> ShowS
+ isNullary :: f a -> Bool
+ isNullary = error "generic show (isNullary): unnecessary case"
+
+instance GShow' U1 where
+ gshowsPrec' _ _ U1 = id
+ isNullary _ = True
+
+instance (GShow c) => GShow' (K1 i c) where
+ gshowsPrec' _ n (K1 a) = gshowsPrec n a
+ isNullary _ = False
+
+-- 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) =
+ case (fixity, conIsTuple c) of
+ (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))
+ (Infix _ m,_) -> showParen (n > m) (showBraces t (gshowsPrec' t m x))
+ where fixity = conFixity c
+ t = if (conIsRecord c) then Rec else
+ if (conIsTuple c) then Tup else
+ case fixity of
+ Prefix -> Pref
+ Infix _ _ -> Inf (show (conName c))
+ showBraces :: Type -> ShowS -> ShowS
+ showBraces Rec p = showChar '{' . p . showChar '}'
+ showBraces Tup p = showChar '(' . p . showChar ')'
+ showBraces Pref p = p
+ showBraces (Inf _) p = p
+ 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
+ gshowsPrec' t n s@(M1 x) | selName s == "" = showParen (n > 10)
+ (gshowsPrec' t n x)
+ | otherwise = showString (selName s)
+ . showString " = "
+ . gshowsPrec' t 0 x
+ isNullary (M1 x) = isNullary x
+
+instance (GShow' a) => GShow' (M1 D d a) where
+ gshowsPrec' t n (M1 x) = gshowsPrec' t n x
+
+instance (GShow' a, GShow' b) => GShow' (a :+: b) where
+ gshowsPrec' t n (L1 x) = gshowsPrec' t n x
+ gshowsPrec' t n (R1 x) = gshowsPrec' t n x
+
+instance (GShow' a, GShow' b) => GShow' (a :*: b) where
+ gshowsPrec' t@Rec n (a :*: b) =
+ gshowsPrec' t n a . showString ", " . gshowsPrec' t n b
+ gshowsPrec' t@(Inf s) n (a :*: b) =
+ gshowsPrec' t n a . showString s . gshowsPrec' t n b
+ gshowsPrec' t@Tup n (a :*: b) =
+ 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
+ gshowsPrec :: Int -> a -> ShowS
+ default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS
+ gshowsPrec n = gshowsPrec' Pref n . from
+
+ gshows :: a -> ShowS
+ gshows = gshowsPrec 0
+
+ gshow :: a -> String
+ gshow x = gshows x ""
+
+
+-- Base types instances
+instance GShow Char where gshowsPrec = showsPrec
+instance GShow Int where gshowsPrec = showsPrec
+instance GShow Float where gshowsPrec = showsPrec
+instance GShow String where gshowsPrec = showsPrec
+instance GShow Bool where gshowsPrec = showsPrec
+
+intersperse :: a -> [a] -> [a]
+intersperse _ [] = []
+intersperse _ [h] = [h]
+intersperse x (h:t) = h : x : (intersperse x t)
+
+instance (GShow a) => GShow [a] where
+ gshowsPrec _ l = showChar '['
+ . foldr (.) id
+ (intersperse (showChar ',') (map (gshowsPrec 0) l))
+ . showChar ']'
+
+instance (GShow a) => GShow (Maybe a)
+instance (GShow a, GShow b) => GShow (a,b)
diff --git a/testsuite/tests/generics/GShow/GShow1.stdout b/testsuite/tests/generics/GShow/GShow1.stdout
new file mode 100644
index 0000000000..6109e446a5
--- /dev/null
+++ b/testsuite/tests/generics/GShow/GShow1.stdout
@@ -0,0 +1,3 @@
+D0
+D1 {d11 = Just 'p', d12 = D0}
+D1 {d11 = (3,0.14), d12 = D0}
diff --git a/testsuite/tests/generics/GShow/Main.hs b/testsuite/tests/generics/GShow/Main.hs
new file mode 100644
index 0000000000..81768ed647
--- /dev/null
+++ b/testsuite/tests/generics/GShow/Main.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+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
+
+-- Example values
+d0 :: D Char
+d0 = D0
+d1 = D1 (Just 'p') D0
+
+d2 :: D (Int,Float)
+d2 = D1 (3,0.14) D0
+
+-- Generic instances
+instance (GShow a) => GShow (D a)
+
+-- Tests
+main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2]
diff --git a/testsuite/tests/generics/GShow/Makefile b/testsuite/tests/generics/GShow/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/generics/GShow/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/generics/GShow/test.T b/testsuite/tests/generics/GShow/test.T
new file mode 100644
index 0000000000..68770ba884
--- /dev/null
+++ b/testsuite/tests/generics/GShow/test.T
@@ -0,0 +1,3 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GShow1', normal, multimod_compile_and_run, ['Main', '']) \ No newline at end of file
diff --git a/testsuite/tests/generics/GenCanDoRep0.hs b/testsuite/tests/generics/GenCanDoRep0.hs
new file mode 100644
index 0000000000..a86416b052
--- /dev/null
+++ b/testsuite/tests/generics/GenCanDoRep0.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+module CanDoRep0 where
+
+import GHC.Generics (Generic)
+
+
+-- We should be able to generate a generic representation for these types
+data A
+ deriving Generic
+
+data B a
+ deriving Generic
+
+data C = C0 | C1
+ deriving Generic
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+ deriving Generic
+
+data (:*:) a b = a :*: b
+ deriving Generic
diff --git a/testsuite/tests/generics/GenCannotDoRep0.hs b/testsuite/tests/generics/GenCannotDoRep0.hs
new file mode 100644
index 0000000000..5b4f93f94f
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep0.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+module CannotDoRep0 where
+
+import GHC.Generics
+
+-- We do not support existential quantification
+data Dynamic = forall a. Dynamic a deriving Generic
diff --git a/testsuite/tests/generics/GenCannotDoRep0.stderr b/testsuite/tests/generics/GenCannotDoRep0.stderr
new file mode 100644
index 0000000000..b5d2f01381
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep0.stderr
@@ -0,0 +1,5 @@
+
+GenCannotDoRep0.hs:9:45:
+ Can't make a derived instance of `Generic Dynamic':
+ Dynamic must be a vanilla data constructor
+ In the data type declaration for `Dynamic'
diff --git a/testsuite/tests/generics/GenCannotDoRep1.hs b/testsuite/tests/generics/GenCannotDoRep1.hs
new file mode 100644
index 0000000000..98ad108dbf
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveGeneric, DatatypeContexts #-}
+
+module CannotDoRep1 where
+
+import GHC.Generics
+
+-- We do not support datatypes with context
+data (Show a) => Context a = Context a deriving Generic
diff --git a/testsuite/tests/generics/GenCannotDoRep1.stderr b/testsuite/tests/generics/GenCannotDoRep1.stderr
new file mode 100644
index 0000000000..477a2955ce
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep1.stderr
@@ -0,0 +1,8 @@
+
+GenCannotDoRep1.hs:1:29:
+ Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
+GenCannotDoRep1.hs:8:49:
+ Can't make a derived instance of `Generic (Context a)':
+ Context must not have a datatype context
+ In the data type declaration for `Context'
diff --git a/testsuite/tests/generics/GenCannotDoRep2.hs b/testsuite/tests/generics/GenCannotDoRep2.hs
new file mode 100644
index 0000000000..ad816f4ce4
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep2.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+
+module CannotDoRep2 where
+
+import GHC.Generics
+
+-- We do not support GADTs
+data Term a where
+ Int :: Term Int
+
+deriving instance Generic (Term a)
diff --git a/testsuite/tests/generics/GenCannotDoRep2.stderr b/testsuite/tests/generics/GenCannotDoRep2.stderr
new file mode 100644
index 0000000000..35caf2c3b4
--- /dev/null
+++ b/testsuite/tests/generics/GenCannotDoRep2.stderr
@@ -0,0 +1,5 @@
+
+GenCannotDoRep2.hs:13:1:
+ Can't make a derived instance of `Generic (Term a)':
+ Int must be a vanilla data constructor
+ In the stand-alone deriving instance for `Generic (Term a)'
diff --git a/testsuite/tests/generics/GenDeprecated.stderr b/testsuite/tests/generics/GenDeprecated.stderr
new file mode 100644
index 0000000000..d07c35d3a3
--- /dev/null
+++ b/testsuite/tests/generics/GenDeprecated.stderr
@@ -0,0 +1,3 @@
+
+GenDeprecated.hs:1:14:
+ Warning: -XGenerics is deprecated: it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.
diff --git a/testsuite/tests/generics/GenShouldFail0.hs b/testsuite/tests/generics/GenShouldFail0.hs
new file mode 100644
index 0000000000..cc1ef6ff42
--- /dev/null
+++ b/testsuite/tests/generics/GenShouldFail0.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE StandaloneDeriving #-}
+
+module ShouldFail0 where
+
+import GHC.Generics (Generic)
+
+data X = X
+
+deriving instance Generic X
+
+-- Should fail (no XDeriveGeneric)
diff --git a/testsuite/tests/generics/GenShouldFail0.stderr b/testsuite/tests/generics/GenShouldFail0.stderr
new file mode 100644
index 0000000000..3685e67784
--- /dev/null
+++ b/testsuite/tests/generics/GenShouldFail0.stderr
@@ -0,0 +1,5 @@
+
+GenShouldFail0.hs:9:1:
+ Can't make a derived instance of `Generic X':
+ You need -XDeriveGeneric to derive an instance for this class
+ In the stand-alone deriving instance for `Generic X'
diff --git a/testsuite/tests/generics/Makefile b/testsuite/tests/generics/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/generics/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/generics/Uniplate/GUniplate.hs b/testsuite/tests/generics/Uniplate/GUniplate.hs
new file mode 100644
index 0000000000..76f387d636
--- /dev/null
+++ b/testsuite/tests/generics/Uniplate/GUniplate.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE IncoherentInstances #-} -- necessary, unfortunately
+
+module GUniplate 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 :: (Generic a, Uniplate' (Rep a) a) => a -> [a]
+ children = children' . from
+
+
+-- 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/generics/Uniplate/GUniplate1.stdout b/testsuite/tests/generics/Uniplate/GUniplate1.stdout
new file mode 100644
index 0000000000..f560e40162
--- /dev/null
+++ b/testsuite/tests/generics/Uniplate/GUniplate1.stdout
@@ -0,0 +1 @@
+("",[],[Leaf,Leaf])
diff --git a/testsuite/tests/generics/Uniplate/Main.hs b/testsuite/tests/generics/Uniplate/Main.hs
new file mode 100644
index 0000000000..95d84244fa
--- /dev/null
+++ b/testsuite/tests/generics/Uniplate/Main.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+import GHC.Generics
+import GUniplate
+
+
+data Tree = Leaf | Node Int Tree Tree deriving (Show, Generic)
+data Pair a b = Pair a b deriving (Show, Generic)
+
+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/generics/Uniplate/Makefile b/testsuite/tests/generics/Uniplate/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/generics/Uniplate/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/generics/Uniplate/test.T b/testsuite/tests/generics/Uniplate/test.T
new file mode 100644
index 0000000000..a1e610726e
--- /dev/null
+++ b/testsuite/tests/generics/Uniplate/test.T
@@ -0,0 +1,3 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GUniplate1', normal, multimod_compile_and_run, ['Main', '']) \ No newline at end of file
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
new file mode 100644
index 0000000000..5ef616c811
--- /dev/null
+++ b/testsuite/tests/generics/all.T
@@ -0,0 +1,8 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GenCanDoRep0', normal, compile, [''])
+
+test('GenShouldFail0', normal, compile_fail, [''])
+test('GenCannotDoRep0', normal, compile_fail, [''])
+test('GenCannotDoRep1', normal, compile_fail, [''])
+test('GenCannotDoRep2', normal, compile_fail, [''])