Move tests from tests/ghc-regress/* to just tests/*

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