Implement #5462 (deriving clause for arbitrary classes)

Summary: (this has been submitted on behalf on @dreixel)

Reviewers: simonpj, hvr, austin

Reviewed By: simonpj, austin

Subscribers: goldfire, thomie, carter, dreixel

Differential Revision: https://phabricator.haskell.org/D476

GHC Trac Issues: #5462

9 files changed, 230 insertions, 6 deletions

diff --git a/testsuite/tests/generics/GEnum/Enum.hs b/testsuite/tests/generics/GEnum/Enum.hs
new file mode 100644
index 0000000000..5bf99b45a4
--- /dev/null
+++ b/testsuite/tests/generics/GEnum/Enum.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+
+module Enum where
+
+
+import GHC.Generics
+
+
+-----------------------------------------------------------------------------
+-- Utility functions for Enum'
+-----------------------------------------------------------------------------
+
+infixr 5 |||
+
+-- | Interleave elements from two lists. Similar to (++), but swap left and
+-- right arguments on every recursive application.
+--
+-- From Mark Jones' talk at AFP2008
+(|||) :: [a] -> [a] -> [a]
+[]     ||| ys = ys
+(x:xs) ||| ys = x : ys ||| xs
+
+-- | Diagonalization of nested lists. Ensure that some elements from every
+-- sublist will be included. Handles infinite sublists.
+--
+-- From Mark Jones' talk at AFP2008
+diag :: [[a]] -> [a]
+diag = concat . foldr skew [] . map (map (\x -> [x]))
+
+skew :: [[a]] -> [[a]] -> [[a]]
+skew []     ys = ys
+skew (x:xs) ys = x : combine (++) xs ys
+
+combine :: (a -> a -> a) -> [a] -> [a] -> [a]
+combine _ xs     []     = xs
+combine _ []     ys     = ys
+combine f (x:xs) (y:ys) = f x y : combine f xs ys
+
+findIndex :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
+                 in if (null l)
+                    then Nothing
+                    else Just (head l)
+
+--------------------------------------------------------------------------------
+-- Generic enum
+--------------------------------------------------------------------------------
+
+class Enum' f where
+  enum' :: [f a]
+
+instance Enum' U1 where
+  enum' = [U1]
+
+instance (GEnum c) => Enum' (K1 i c) where
+  enum' = map K1 genum
+
+instance (Enum' f) => Enum' (M1 i c f) where
+  enum' = map M1 enum'
+
+instance (Enum' f, Enum' g) => Enum' (f :+: g) where
+  enum' = map L1 enum' ||| map R1 enum'
+
+instance (Enum' f, Enum' g) => Enum' (f :*: g) where
+  enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]
+
+instance (GEnum a) => GEnum (Maybe a)
+instance (GEnum a) => GEnum [a]
+
+
+genumDefault :: (Generic a, Enum' (Rep a)) => [a]
+genumDefault = map to enum'
+
+class GEnum a where
+  genum :: [a]
+
+  default genum :: (Generic a, Enum' (Rep a)) => [a]
+  genum = genumDefault
+
+instance GEnum Int where
+  genum = [0..] ||| (neg 0) where
+    neg n = (n-1) : neg (n-1)
diff --git a/testsuite/tests/generics/GEq/GEq1A.hs b/testsuite/tests/generics/GEq/GEq1A.hs
index 6450091393..7bdfbebe54 100644
--- a/testsuite/tests/generics/GEq/GEq1A.hs
+++ b/testsuite/tests/generics/GEq/GEq1A.hs
@@ -37,8 +37,7 @@ class GEq a where
 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]
--}
diff --git a/testsuite/tests/generics/T5462No1.hs b/testsuite/tests/generics/T5462No1.hs
new file mode 100644
index 0000000000..fc24f63431
--- /dev/null
+++ b/testsuite/tests/generics/T5462No1.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE DefaultSignatures      #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+-- DeriveAnyClass not enabled
+
+module T5462No1 where
+
+import GHC.Generics hiding (C, C1, D)
+import GFunctor
+
+class C1 a where
+  c1 :: a -> Int
+
+class C2 a where
+  c2 :: a -> Int
+  c2 _ = 0
+
+newtype F a = F1 [a]
+  deriving (Show, Eq, Generic, Generic1, GFunctor)
+
+data G = G1 deriving (C1)
+data H = H1 deriving (C2)
diff --git a/testsuite/tests/generics/T5462No1.stderr b/testsuite/tests/generics/T5462No1.stderr
new file mode 100644
index 0000000000..9deb08a9f9
--- /dev/null
+++ b/testsuite/tests/generics/T5462No1.stderr
@@ -0,0 +1,20 @@
+[1 of 2] Compiling GFunctor         ( GFunctor/GFunctor.hs, GFunctor/GFunctor.o )
+[2 of 2] Compiling T5462No1         ( T5462No1.hs, T5462No1.o )
+
+T5462No1.hs:24:42:
+    Can't make a derived instance of ‘GFunctor F’:
+      ‘GFunctor’ is not a derivable class
+      Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
+    In the newtype declaration for ‘F’
+
+T5462No1.hs:26:23:
+    Can't make a derived instance of ‘C1 G’:
+      ‘C1’ is not a derivable class
+      Try enabling DeriveAnyClass
+    In the data declaration for ‘G’
+
+T5462No1.hs:27:23:
+    Can't make a derived instance of ‘C2 H’:
+      ‘C2’ is not a derivable class
+      Try enabling DeriveAnyClass
+    In the data declaration for ‘H’
diff --git a/testsuite/tests/generics/T5462Yes1.hs b/testsuite/tests/generics/T5462Yes1.hs
new file mode 100644
index 0000000000..35785295d6
--- /dev/null
+++ b/testsuite/tests/generics/T5462Yes1.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE DefaultSignatures      #-}
+{-# LANGUAGE StandaloneDeriving     #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+
+module Main where
+
+import GHC.Generics hiding (C, C1, D)
+import GEq1A
+import Enum
+import GFunctor
+
+data A = A1
+  deriving (Show, Generic, GEq, GEnum)
+
+data B a = B1 | B2 a (B a)
+  deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)
+
+data C phantom a = C1 | C2 a (C phantom a)
+  deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)
+
+data D f a = D1 (f a) (f (D f a)) deriving (Generic, Generic1)
+deriving instance (Show (f a), Show (f (D f a))) => Show (D f a)
+deriving instance (GEq  (f a), GEq  (f (D f a))) => GEq  (D f a)
+
+data E f a = E1 (f a)
+  deriving (Show, Eq, Generic, Generic1, GFunctor)
+
+
+main = print (
+               geq A1 A1
+             , take 10 (genum :: [A])
+
+             , geq (B2 A1 B1) B1
+             , gmap (++ "lo") (B2 "hel" B1)
+             , take 3 (genum :: [B A])
+
+             , geq (C2 A1 C1) C1
+             , gmap (++ "lo") (C2 "hel" C1)
+
+             , geq (D1 "a" []) (D1 "a" [])
+
+             , gmap (++ "lo") (E1 ["hel"])
+             )
diff --git a/testsuite/tests/generics/T5462Yes1.stdout b/testsuite/tests/generics/T5462Yes1.stdout
new file mode 100644
index 0000000000..6a2dc672a6
--- /dev/null
+++ b/testsuite/tests/generics/T5462Yes1.stdout
@@ -0,0 +1 @@
+(True,[A1],False,B2 "hello" B1,[B1,B2 A1 B1,B2 A1 (B2 A1 B1)],False,C2 "hello" C1,True,E1 ["hello"])

diff --git a/testsuite/tests/generics/T5462Yes2.hs b/testsuite/tests/generics/T5462Yes2.hs
new file mode 100644
index 0000000000..9c222554aa
--- /dev/null
+++ b/testsuite/tests/generics/T5462Yes2.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts              #-}
+{-# LANGUAGE FlexibleInstances             #-}
+{-# LANGUAGE DeriveGeneric                 #-}
+{-# LANGUAGE DefaultSignatures             #-}
+{-# LANGUAGE StandaloneDeriving            #-}
+{-# LANGUAGE UndecidableInstances          #-}
+{-# LANGUAGE DeriveAnyClass                #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving    #-}
+
+module Main where
+
+import GHC.Generics hiding (C, C1, D)
+import GFunctor
+
+class C1 a where
+  c1 :: a -> Int
+  c1 _ = 1
+
+class C2 a where
+  c21 :: a -> Int
+  c21 = c22
+  c22 :: a -> Int
+  c22 = c21
+  {-# MINIMAL c21 | c22 #-}
+
+newtype D = D Int deriving C1
+
+instance C1 Int where c1 _ = 2
+
+newtype F a = F1 [a]
+  deriving (Show, Eq, Generic, Generic1, GFunctor)
+
+data G = G1 deriving (C1)
+data H = H1 deriving (C2)
+
+
+main = print (c1 (D 3))
diff --git a/testsuite/tests/generics/T5462Yes2.stdout b/testsuite/tests/generics/T5462Yes2.stdout
new file mode 100644
index 0000000000..d00491fd7e
--- /dev/null
+++ b/testsuite/tests/generics/T5462Yes2.stdout
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index df95fa604f..694f214633 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -19,11 +19,15 @@ test('GenCannotDoRep1_6', normal, compile_fail, [''])
 test('GenCannotDoRep1_7', normal, compile_fail, [''])
 test('GenCannotDoRep1_8', normal, compile_fail, [''])
 
-test('T5884',           normal, compile, [''])
-test('GenNewtype',      normal, compile_and_run, [''])
+test('T5462Yes1', normal, multimod_compile_and_run, ['T5462Yes1', '-iGEq -iGEnum -iGFunctor'])
+test('T5462Yes2', normal, multimod_compile_and_run, ['T5462Yes2', '-iGFunctor'])
+test('T5462No1', normal, multimod_compile_fail, ['T5462No1', '-iGFunctor'])
 
-test('GenDerivOutput1_0',  normal, compile, ['-dsuppress-uniques'])
-test('GenDerivOutput1_1',  normal, compile, ['-dsuppress-uniques'])
+test('T5884',      normal, compile, [''])
+test('GenNewtype', normal, compile_and_run, [''])
+
+test('GenDerivOutput1_0', normal, compile, ['-dsuppress-uniques'])
+test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques'])
 
 test('T7878', extra_clean(['T7878A.o'     ,'T7878A.hi'
                           ,'T7878A.o-boot','T7878A.hi-boot'