Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : ghc-generics
http://hackage.haskell.org/trac/ghc/changeset/127c35ea5fbb9595a55151c0f4a66184283f8b8a >--------------------------------------------------------------- commit 127c35ea5fbb9595a55151c0f4a66184283f8b8a Author: Jose Pedro Magalhaes <[email protected]> Date: Tue May 3 13:22:26 2011 +0200 More tests for the new generic deriving mechanism. >--------------------------------------------------------------- tests/ghc-regress/generics/GShow/GShow.hs | 124 ++++++++++++++++++++ .../generics/GShow/GShow1.interp.stdout | 4 + tests/ghc-regress/generics/GShow/GShow1.stdout | 3 + tests/ghc-regress/generics/GShow/Main.hs | 23 ++++ .../{array/should_run => generics/GShow}/Makefile | 0 tests/ghc-regress/generics/GShow/test.T | 3 + tests/ghc-regress/generics/canDoRep0.hs | 4 + 7 files changed, 161 insertions(+), 0 deletions(-) diff --git a/tests/ghc-regress/generics/GShow/GShow.hs b/tests/ghc-regress/generics/GShow/GShow.hs new file mode 100644 index 0000000..564fe7a --- /dev/null +++ b/tests/ghc-regress/generics/GShow/GShow.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE IncoherentInstances #-} -- :-/ +{-# LANGUAGE Generics #-} + +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 :: (Representable0 a, GShow' (Rep0 a)) => Int -> a -> ShowS + gshowsPrec n = gshowsPrec' Pref n . from0 + + 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/tests/ghc-regress/generics/GShow/GShow1.interp.stdout b/tests/ghc-regress/generics/GShow/GShow1.interp.stdout new file mode 100644 index 0000000..9da37fb --- /dev/null +++ b/tests/ghc-regress/generics/GShow/GShow1.interp.stdout @@ -0,0 +1,4 @@ +===== program output begins here +D0 +D1 {d11 = Just 'p', d12 = D0} +D1 {d11 = (3,0.14), d12 = D0} diff --git a/tests/ghc-regress/generics/GShow/GShow1.stdout b/tests/ghc-regress/generics/GShow/GShow1.stdout new file mode 100644 index 0000000..6109e44 --- /dev/null +++ b/tests/ghc-regress/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/tests/ghc-regress/generics/GShow/Main.hs b/tests/ghc-regress/generics/GShow/Main.hs new file mode 100644 index 0000000..a59a171 --- /dev/null +++ b/tests/ghc-regress/generics/GShow/Main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveRepresentable #-} + +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 Representable0 + +-- 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/tests/ghc-regress/array/should_run/Makefile b/tests/ghc-regress/generics/GShow/Makefile similarity index 100% copy from tests/ghc-regress/array/should_run/Makefile copy to tests/ghc-regress/generics/GShow/Makefile diff --git a/tests/ghc-regress/generics/GShow/test.T b/tests/ghc-regress/generics/GShow/test.T new file mode 100644 index 0000000..68770ba --- /dev/null +++ b/tests/ghc-regress/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/tests/ghc-regress/generics/canDoRep0.hs b/tests/ghc-regress/generics/canDoRep0.hs index 59e6c97..e94e547 100644 --- a/tests/ghc-regress/generics/canDoRep0.hs +++ b/tests/ghc-regress/generics/canDoRep0.hs @@ -12,3 +12,7 @@ data C = C0 | C1 data D a = D0 | D1 { d11 :: a, d12 :: (D a) } data E a = E0 a (E a) (D a) + +-- We do not support datatype contexts, but this should still compile +-- (Context will simply have no Representable0 instance) +data (Show a) => Context a = Context a _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
