diff options
Diffstat (limited to 'testsuite/tests/generics/GShow')
| -rw-r--r-- | testsuite/tests/generics/GShow/GShow.hs | 124 | ||||
| -rw-r--r-- | testsuite/tests/generics/GShow/GShow1.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/generics/GShow/Main.hs | 23 | ||||
| -rw-r--r-- | testsuite/tests/generics/GShow/Makefile | 3 | ||||
| -rw-r--r-- | testsuite/tests/generics/GShow/test.T | 3 |
5 files changed, 156 insertions, 0 deletions
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 |