[commit: testsuite] ghc-generics: Add tests for deriving Generic1. (654c986)
José Pedro Magalhães
jpm at cs.uu.nl
Thu Jul 28 15:45:35 CEST 2011
Repository : ssh://darcs.haskell.org//srv/darcs/testsuite
On branch : ghc-generics
http://hackage.haskell.org/trac/ghc/changeset/654c986a3bb8d7ba7c03ee87e850b48d04cf66fc
>---------------------------------------------------------------
commit 654c986a3bb8d7ba7c03ee87e850b48d04cf66fc
Author: Jose Pedro Magalhaes <jpm at cs.uu.nl>
Date: Thu Jul 28 13:45:50 2011 +0200
Add tests for deriving Generic1.
>---------------------------------------------------------------
tests/generics/GMap/GMap.hs | 56 ++++++++++++++++++++
tests/generics/GMap/GMap1.stdout | 1 +
tests/generics/GMap/Main.hs | 22 ++++++++
.../should_compile => generics/GMap}/Makefile | 0
tests/generics/GMap/test.T | 3 +
tests/generics/GenCanDoRep.hs | 35 ++++++++++++
tests/generics/GenCanDoRep0.hs | 23 --------
tests/generics/GenCannotDoRep3.hs | 8 +++
tests/generics/GenCannotDoRep3.stderr | 5 ++
tests/generics/all.T | 3 +-
10 files changed, 132 insertions(+), 24 deletions(-)
diff --git a/tests/generics/GMap/GMap.hs b/tests/generics/GMap/GMap.hs
new file mode 100644
index 0000000..795d7c4
--- /dev/null
+++ b/tests/generics/GMap/GMap.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+
+module GMap (
+ -- * Generic show class
+ GMap(..)
+ ) where
+
+
+import GHC.Generics
+
+--------------------------------------------------------------------------------
+-- Generic map
+--------------------------------------------------------------------------------
+
+class GMap' f where
+ gmap' :: (a -> b) -> f a -> f b
+
+instance GMap' U1 where
+ gmap' _ U1 = U1
+
+instance GMap' Par1 where
+ gmap' f (Par1 a) = Par1 (f a)
+
+instance GMap' (K1 i c) where
+ gmap' _ (K1 a) = K1 a
+
+instance (GMap f) => GMap' (Rec1 f) where
+ gmap' f (Rec1 a) = Rec1 (gmap f a)
+
+instance (GMap' f) => GMap' (M1 i c f) where
+ gmap' f (M1 a) = M1 (gmap' f a)
+
+instance (GMap' f, GMap' g) => GMap' (f :+: g) where
+ gmap' f (L1 a) = L1 (gmap' f a)
+ gmap' f (R1 a) = R1 (gmap' f a)
+
+instance (GMap' f, GMap' g) => GMap' (f :*: g) where
+ gmap' f (a :*: b) = gmap' f a :*: gmap' f b
+
+instance (GMap f, GMap' g) => GMap' (f :.: g) where
+ gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)
+
+
+class GMap f where
+ gmap :: (a -> b) -> f a -> f b
+ default gmap :: (Generic1 f, GMap' (Rep1 f))
+ => (a -> b) -> f a -> f b
+ gmap = gmapdefault
+
+gmapdefault :: (Generic1 f, GMap' (Rep1 f))
+ => (a -> b) -> f a -> f b
+gmapdefault f = to1 . gmap' f . from1
diff --git a/tests/generics/GMap/GMap1.stdout b/tests/generics/GMap/GMap1.stdout
new file mode 100644
index 0000000..04e0b44
--- /dev/null
+++ b/tests/generics/GMap/GMap1.stdout
@@ -0,0 +1 @@
+(D1 {d11 = 1, d12 = D0},D1 {d11 = (0.14,3), d12 = D0})
diff --git a/tests/generics/GMap/Main.hs b/tests/generics/GMap/Main.hs
new file mode 100644
index 0000000..4b34ca5
--- /dev/null
+++ b/tests/generics/GMap/Main.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+import GHC.Generics hiding (C, D)
+import GMap
+
+-- We should be able to generate a generic representation for these types
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) } deriving (Show, Generic1)
+
+-- Example values
+d0 :: D Int
+d0 = D1 0 D0
+
+d1 :: D (Int,Float)
+d1 = D1 (3,0.14) D0
+
+-- Generic instances
+instance GMap D
+
+-- Tests
+main = print (gmap (+1) d0, gmap (\(a,b) -> (b,a)) d1)
diff --git a/tests/annotations/should_compile/Makefile b/tests/generics/GMap/Makefile
similarity index 100%
copy from tests/annotations/should_compile/Makefile
copy to tests/generics/GMap/Makefile
diff --git a/tests/generics/GMap/test.T b/tests/generics/GMap/test.T
new file mode 100644
index 0000000..f07ae5c
--- /dev/null
+++ b/tests/generics/GMap/test.T
@@ -0,0 +1,3 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('GMap1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
diff --git a/tests/generics/GenCanDoRep.hs b/tests/generics/GenCanDoRep.hs
new file mode 100644
index 0000000..c4327d7
--- /dev/null
+++ b/tests/generics/GenCanDoRep.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+module CanDoRep0 where
+
+import GHC.Generics (Generic, Generic1)
+
+
+-- We should be able to generate a generic representation for these types
+data A
+ deriving Generic
+
+data B a
+ deriving (Generic, Generic1)
+
+data B' a
+ deriving Generic1
+
+data C = C0 | C1
+ deriving Generic
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+ deriving (Generic, Generic1)
+
+data (:*:) a b = a :*: b
+ deriving Generic
+
+data Bush a = BushNil | BushCons a (Bush (Bush a))
+ deriving (Generic, Generic1)
+
+data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }
+ deriving (Generic, Generic1)
+
+data Rose a = Rose [a] [Rose a]
+ deriving (Generic, Generic1)
diff --git a/tests/generics/GenCanDoRep0.hs b/tests/generics/GenCanDoRep0.hs
deleted file mode 100644
index a86416b..0000000
--- a/tests/generics/GenCanDoRep0.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# 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/tests/generics/GenCannotDoRep3.hs b/tests/generics/GenCannotDoRep3.hs
new file mode 100644
index 0000000..53fc78c
--- /dev/null
+++ b/tests/generics/GenCannotDoRep3.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module CannotDoRep3 where
+
+import GHC.Generics
+
+-- Only types that can derive Functor can derive Generic1
+data Simple = Simple deriving Generic1
diff --git a/tests/generics/GenCannotDoRep3.stderr b/tests/generics/GenCannotDoRep3.stderr
new file mode 100644
index 0000000..c5c96a3
--- /dev/null
+++ b/tests/generics/GenCannotDoRep3.stderr
@@ -0,0 +1,5 @@
+
+GenCannotDoRep3.hs:8:31:
+ Cannot derive well-kinded instance of form `Generic1 (Simple ...)'
+ Class `Generic1' expects an argument of kind `* -> *'
+ In the data type declaration for `Simple'
diff --git a/tests/generics/all.T b/tests/generics/all.T
index 5ef616c..c6aabe5 100644
--- a/tests/generics/all.T
+++ b/tests/generics/all.T
@@ -1,8 +1,9 @@
setTestOpts(only_compiler_types(['ghc']))
-test('GenCanDoRep0', normal, compile, [''])
+test('GenCanDoRep', normal, compile, [''])
test('GenShouldFail0', normal, compile_fail, [''])
test('GenCannotDoRep0', normal, compile_fail, [''])
test('GenCannotDoRep1', normal, compile_fail, [''])
test('GenCannotDoRep2', normal, compile_fail, [''])
+test('GenCannotDoRep3', normal, compile_fail, [''])
More information about the Cvs-ghc
mailing list