[commit: ghc] master: Add regression test for #13758 (c823140)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c82314085f2721915ea143a53f09de111aee7edb/ghc

>---------------------------------------------------------------

commit c82314085f2721915ea143a53f09de111aee7edb
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri May 26 18:47:28 2017 -0400

    Add regression test for #13758


>---------------------------------------------------------------

c82314085f2721915ea143a53f09de111aee7edb
 testsuite/tests/deriving/should_compile/T13758.hs | 57 +++++++++++++++++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 2 files changed, 58 insertions(+)

diff --git a/testsuite/tests/deriving/should_compile/T13758.hs b/testsuite/tests/deriving/should_compile/T13758.hs
new file mode 100644
index 0000000..91ddd99
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T13758.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# Language ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T13758 where
+
+import Data.Coerce
+import GHC.Generics
+import Data.Semigroup
+
+-----
+
+class Monoid' f where
+  mempty'  :: f x
+  mappend' :: f x -> f x -> f x
+
+instance Monoid' U1 where
+  mempty' = U1
+  mappend' U1 U1 = U1
+
+instance Monoid a => Monoid' (K1 i a) where
+  mempty' = K1 mempty
+  mappend' (K1 x) (K1 y) = K1 (x `mappend` y)
+
+instance Monoid' f => Monoid' (M1 i c f) where
+  mempty' = M1 mempty'
+  mappend' (M1 x) (M1 y) = M1 (x `mappend'` y)
+
+instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where
+  mempty' = mempty' :*: mempty'
+  mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2
+
+memptydefault :: (Generic a, Monoid' (Rep a)) => a
+memptydefault = to mempty'
+
+mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a
+mappenddefault x y = to (mappend' (from x) (from y))
+
+-----
+
+newtype GenericMonoid a = GenericMonoid a
+
+instance (Generic a, Monoid' (Rep a)) => Semigroup (GenericMonoid a) where
+  (<>) = coerce (mappenddefault :: a -> a -> a)
+
+instance (Generic a, Monoid' (Rep a)) => Monoid (GenericMonoid a) where
+  mempty  = coerce (memptydefault  :: a)
+  mappend = coerce (mappenddefault :: a -> a -> a)
+
+data Urls = Urls String String String
+  deriving (Show, Generic)
+
+newtype UrlsDeriv = UD (GenericMonoid Urls)
+  deriving (Semigroup, Monoid)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 837bb04..36476d5 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -88,5 +88,6 @@ test('T12814', normal, compile, ['-Wredundant-constraints'])
 test('T13272', normal, compile, [''])
 test('T13272a', normal, compile, [''])
 test('T13297', normal, compile, [''])
+test('T13758', normal, compile, [''])
 test('drv-empty-data', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])
 test('drv-phantom', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])