Revert "Revert commits 53b30fac9fc30d9d85cc... and c8244f5cd31774de2e39... as...

Revert "Revert commits 53b30fac9fc30d9d85cc... and c8244f5cd31774de2e39... as they were not intended for master."

This reverts commit d2fab4d8c428fc0a3b0f8ad288fc50d8d6ef0950, because these changes were intended for this branch.

testsuite/tests/ghc-regress/generics/GEq/GEq.hs

+{-# LANGUAGE TypeOperators, Generics, 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' (K1 P c) where
+  geq' (K1 a) (K1 b) = undefined
+
+instance (GEq c) => GEq' (K1 R 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 :: (Representable0 a, GEq' (Rep0 a)) => a -> a -> Bool
+  geq x y = geq' (from0 x) (from0 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]
+-}

testsuite/tests/ghc-regress/generics/GEq/GEq1.stdout

+False
+False
+True

testsuite/tests/ghc-regress/generics/GEq/Main.hs

+{-# LANGUAGE TypeOperators, Generics #-}
+
+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
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+
+-- Example values
+c0 = C0
+c1 = C1
+
+d0 :: D Char
+d0 = D0
+d1 = D1 'p' D0
+
+-- Generic instances
+instance            GEq C
+instance (GEq a) => GEq (D a)
+
+-- Tests
+teq0 = geq c0 c1
+teq1 = geq d0 d1
+teq2 = geq d0 d0
+
+main = mapM_ print [teq0, teq1, teq2]

testsuite/tests/ghc-regress/generics/GEq/Makefile

+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/ghc-regress/generics/GEq/test.T

+setTestOpts(only_compiler_types(['ghc']))
+
+test('GEq1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file

testsuite/tests/ghc-regress/generics/Makefile

+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/ghc-regress/generics/Uniplate/Main.hs

+{-# LANGUAGE Generics #-}
+
+module Main where
+
+import GHC.Generics
+import Uniplate
+
+
+data Tree     = Leaf | Node Int Tree Tree deriving Show
+data Pair a b = Pair a b                  deriving Show
+
+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)

testsuite/tests/ghc-regress/generics/Uniplate/Makefile

+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/ghc-regress/generics/Uniplate/Uniplate.hs

+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE Generics                   #-}
+{-# LANGUAGE IncoherentInstances        #-} -- necessary, unfortunately
+
+module Uniplate 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 :: (Representable0 a, Uniplate' (Rep0 a) a) => a -> [a]
+  children = children' . from0
+
+
+-- 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]

testsuite/tests/ghc-regress/generics/Uniplate/Uniplate1.stdout

+("",[],[Leaf,Leaf])

testsuite/tests/ghc-regress/generics/Uniplate/test.T

+setTestOpts(only_compiler_types(['ghc']))
+
+test('Uniplate1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file

testsuite/tests/ghc-regress/generics/all.T

+setTestOpts(only_compiler_types(['ghc']))
+
+test('canDoRep0', normal, compile, [''])
+
+test('cannotDoRep0', normal, compile_fail, [''])
+test('cannotDoRep1', normal, compile_fail, [''])
+test('cannotDoRep2', normal, compile_fail, [''])

testsuite/tests/ghc-regress/generics/canDoRep0.hs

+{-# LANGUAGE Generics #-}
+
+module ShouldCompile0 where
+
+-- We should be able to generate a generic representation for these types
+data A
+
+data B a
+
+data C = C0 | C1
+
+data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
+
+data E a = E0 a (E a) (D a)

testsuite/tests/ghc-regress/generics/cannotDoRep0.hs

+{-# LANGUAGE DeriveRepresentable        #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+
+module ShouldFail0 where
+
+import GHC.Generics
+
+-- We do not support existential quantification
+data Dynamic = forall a. Dynamic a deriving Representable0

testsuite/tests/ghc-regress/generics/cannotDoRep1.hs

+{-# LANGUAGE DeriveRepresentable #-}
+
+module ShouldFail1 where
+
+import GHC.Generics
+
+-- We do not support datatypes with context
+data (Show a) => Context a = Context a deriving Representable0

testsuite/tests/ghc-regress/generics/cannotDoRep2.hs

+{-# LANGUAGE DeriveRepresentable #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE GADTs               #-}
+
+module ShouldFail2 where
+
+import GHC.Generics
+
+-- We do not support GADTs
+data Term a where
+  Int :: Term Int
+
+deriving instance Representable0 (Term a)

testsuite/tests/ghc-regress/simplCore/should_run/simplrun009.hs

@@ -61,8 +61,11 @@ foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss
 instance StreamableSequence [] where
   stream = listToStream
   unstream = streamToList
+  -- These inline pragmas are useless (see #5084)
+{-
   {-# INLINE stream #-}
   {-# INLINE unstream #-}
+-}
 
 listToStream :: [a] -> Stream a
 listToStream xs = Stream next xs
@@ -104,8 +107,11 @@ class StreamableSequence seq where
   unstream :: Stream a -> seq a
 
   -- axiom: stream . unstream = id
+  -- These inline pragmas are useless (see #5084)
+{-
   {-# INLINE stream #-}
   {-# INLINE unstream #-}
+-}
 
 {-
 --version that does not require the sequence type

testsuite/tests/ghc-regress/typecheck/should_compile/T2573.hs

-{-# LANGUAGE Generics, TypeOperators #-}
-
--- Trac #2573
-
-module ShouldCompile where
-
-import GHC.Base
-
-class Tag a where
-   nCons :: a -> Int
-   nCons {| a :*: b |} _ = 1
-   nCons {| a :+: b |} _ = 1
-   nCons {| Unit |}    _ = 1

testsuite/tests/ghc-regress/typecheck/should_compile/all.T

@@ -296,7 +296,6 @@ test('LoopOfTheDay3', normal, compile, [''])
 
 test('T1470', normal, compile, [''])
 test('T2572', normal, compile, [''])
-test('T2573', normal, compile, [''])
 test('T2735', normal, compile, [''])
 test('T2799', normal, compile, [''])
 test('T3219', normal, compile, [''])
@@ -342,4 +341,4 @@ test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']),
 
 test('T4952', normal, compile, [''])
 test('T4969', normal, compile, [''])
-test('T5120', normal, compile, [''])
\ No newline at end of file
+test('T5120', normal, compile, [''])

testsuite/tests/ghc-regress/typecheck/should_fail/all.T

@@ -150,7 +150,6 @@ test('tcfail159', normal, compile_fail, [''])
 test('tcfail160', normal, compile_fail, [''])
 test('tcfail161', normal, compile_fail, [''])
 test('tcfail162', normal, compile_fail, [''])
-test('tcfail163', normal, compile_fail, [''])
 test('tcfail164', normal, compile_fail, [''])
 test('tcfail165', normal, compile_fail, [''])
 test('tcfail166', normal, compile_fail, [''])

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail163.hs

-
-{-# LANGUAGE ConstrainedClassMethods, Generics, Rank2Types, TypeOperators #-}
-
--- Derivable type class with a higher-rank method
--- Currently this does not work, but it crashed GHC 6.5, so
--- this tests that the error message is civilised.
-  
-module Foo where
-
-import GHC.Base
- 
-class ChurchEncode k where 
- 
-  match :: k 
-      -> z 
-       -> (forall a b z. a -> b -> z)  {- product -} 
-       -> (forall a   z. a -> z)       {- left -} 
-       -> (forall a   z. a -> z)       {- right -} 
-       -> z 
-  
-  match {| Unit    |} Unit      unit prod left right = unit 
-  match {| a :*: b |} (x :*: y) unit prod left right = prod x y 
-  match {| a :+: b |} (Inl l)   unit prod left right = left l 
-  match {| a :+: b |} (Inr r)   unit prod left right = right r 
-  
-  
-instance ChurchEncode Bool 
-
-

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail163.stderr

-
-tcfail163.hs:12:1:
-    Generic method type is too complex
-        match :: forall k.
-                 ChurchEncode k =>
-                 forall z.
-                 k
-                 -> z
-                 -> (forall a b z. a -> b -> z)
-                 -> (forall a z. a -> z)
-                 -> (forall a z. a -> z)
-                 -> z
-        You can only use type variables, arrows, lists, and tuples
-    When checking the class method:
-      match :: k
-               -> z
-               -> (forall a b z. a -> b -> z)
-               -> (forall a z. a -> z)
-               -> (forall a z. a -> z)
-               -> z
-    In the class declaration for `ChurchEncode'