Add Generically (generic Semigroup, Monoid instances) and Generically1 (generic Functor, Applicative, Alternative, Eq1, Ord1 instances) to GHC.Generics.

8 files changed, 225 insertions, 13 deletions

diff --git a/docs/users_guide/exts/generics.rst b/docs/users_guide/exts/generics.rst
index 4299e2ccbf..d32fa246bb 100644
--- a/docs/users_guide/exts/generics.rst
+++ b/docs/users_guide/exts/generics.rst
@@ -3,10 +3,32 @@
 Generic programming
 ===================
 
-Using a combination of :extension:`DeriveGeneric`,
-:extension:`DefaultSignatures`, and :extension:`DeriveAnyClass`, you can
-easily do datatype-generic programming using the :base-ref:`GHC.Generics.`
-framework. This section gives a very brief overview of how to do it.
+There are a few ways to do datatype-generic programming using the
+:base-ref:`GHC.Generics.` framework. One is making use of the
+``Generically`` and ``Generically1`` wrappers from ``GHC.Generics``,
+instances can be derived via them using :extension:`DerivingVia`: ::
+
+    {-# LANGUAGE DeriveGeneric      #-}
+    {-# LANGUAGE DerivingStrategies #-}
+    {-# LANGUAGE DerivingVia        #-}
+
+    import GHC.Generics
+
+    data V4 a = V4 a a a a
+      deriving
+      stock (Generic, Generic1)
+
+      deriving (Semigroup, Monoid)
+      via Generically (V4 a)
+
+      deriving (Functor, Applicative)
+      via Generically1 V4
+
+The older approach uses :extension:`DeriveGeneric`,
+:extension:`DefaultSignatures`, and :extension:`DeriveAnyClass`. It
+derives instances by providing a distinguished generic implementation
+as part of the type class declaration. This section gives a very brief
+overview of how to do it.
 
 Generic programming support in GHC allows defining classes with methods
 that do not need a user specification when instantiating: the method
@@ -248,4 +270,3 @@ original paper [Generics2010]_.
    <http://dreixel.net/research/pdf/gdmh.pdf>`__. Proceedings of
    the third ACM Haskell symposium on Haskell (Haskell'2010), pp. 37-48,
    ACM, 2010.
-
diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs
index 82d78778d7..def3c8acfd 100644
--- a/libraries/base/Data/Functor/Classes.hs
+++ b/libraries/base/Data/Functor/Classes.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE InstanceSigs         #-}
+{-# LANGUAGE Safe                 #-}
+{-# LANGUAGE UndecidableInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Functor.Classes
@@ -72,6 +75,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Ord (Down(Down))
 import Data.Complex (Complex((:+)))
 
+import GHC.Generics (Generic1(..), Generically1(..))
 import GHC.Tuple (Solo (..))
 import GHC.Read (expectP, list, paren)
 import Data.Fixed (Fixed (..))
@@ -688,6 +692,15 @@ instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where
 instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where
     liftShowsPrec = liftShowsPrec2 showsPrec showList
 
+-- | @since 4.17.0.0
+instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where
+  liftEq :: (a1 -> a2 -> Bool) -> (Generically1 f a1 -> Generically1 f a2 -> Bool)
+  liftEq (===) (Generically1 as1) (Generically1 as2) = liftEq (===) (from1 as1) (from1 as2)
+
+-- | @since 4.17.0.0
+instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where
+  liftCompare :: (a1 -> a2 -> Ordering) -> (Generically1 f a1 -> Generically1 f a2 -> Ordering)
+  liftCompare cmp (Generically1 as1) (Generically1 as2) = liftCompare cmp (from1 as1) (from1 as2)
 
 -- | @since 4.9.0.0
 instance Eq2 Either where
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index a8e7124e95..d4f56fd1e6 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-}
+
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveFunctor              #-}
@@ -7,12 +9,15 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs               #-}
 {-# LANGUAGE MagicHash                  #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE PolyKinds                  #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
 {-# LANGUAGE Trustworthy                #-}
+{-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
@@ -720,17 +725,21 @@ module GHC.Generics  (
   , Meta(..)
 
   -- * Generic type classes
-  , Generic(..), Generic1(..)
+  , Generic(..)
+  , Generic1(..)
 
+  -- * Generic wrapper
+  , Generically(..)
+  , Generically1(..)
   ) where
 
 -- We use some base types
-import Data.Either ( Either (..) )
-import Data.Maybe  ( Maybe(..), fromMaybe )
-import Data.Ord    ( Down(..) )
+import Data.Either     ( Either (..) )
+import Data.Maybe      ( Maybe(..), fromMaybe )
+import Data.Ord        ( Down(..) )
 import GHC.Num.Integer ( Integer, integerToInt )
-import GHC.Prim    ( Addr#, Char#, Double#, Float#, Int#, Word# )
-import GHC.Ptr     ( Ptr )
+import GHC.Prim        ( Addr#, Char#, Double#, Float#, Int#, Word# )
+import GHC.Ptr         ( Ptr )
 import GHC.Types
 
 -- Needed for instances
@@ -1366,6 +1375,147 @@ class Generic1 (f :: k -> Type) where
   to1    :: (Rep1 f) a -> f a
 
 --------------------------------------------------------------------------------
+-- 'Generic' wrapper
+--------------------------------------------------------------------------------
+
+-- | A datatype whose instances are defined generically, using the
+-- 'Generic' representation. 'Generically1' is a higher-kinded version
+-- of 'Generically' that uses 'Generic1'.
+--
+-- Generic instances can be derived via @'Generically' A@ using
+-- @-XDerivingVia@.
+--
+-- @
+-- {-# LANGUAGE DeriveGeneric      #-}
+-- {-# LANGUAGE DerivingStrategies #-}
+-- {-# LANGUAGE DerivingVia        #-}
+--
+-- import GHC.Generics (Generic)
+--
+-- data V4 a = V4 a a a a
+--   deriving stock Generic
+--
+--   deriving (Semigroup, Monoid)
+--   via Generically (V4 a)
+-- @
+--
+-- This corresponds to 'Semigroup' and 'Monoid' instances defined by
+-- pointwise lifting:
+--
+-- @
+-- instance Semigroup a => Semigroup (V4 a) where
+--   (<>) :: V4 a -> V4 a -> V4 a
+--   V4 a1 b1 c1 d1 <> V4 a2 b2 c2 d2 =
+--     V4 (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2)
+--
+-- instance Monoid a => Monoid (V4 a) where
+--   mempty :: V4 a
+--   mempty = V4 mempty mempty mempty mempty
+-- @
+--
+-- Historically this required modifying the type class to include
+-- generic method definitions (@-XDefaultSignatures@) and deriving it
+-- with the @anyclass@ strategy (@-XDeriveAnyClass@). Having a /via
+-- type/ like 'Generically' decouples the instance from the type
+-- class.
+--
+-- @since 4.17.0.0
+newtype Generically a = Generically a
+
+-- | @since 4.17.0.0
+instance (Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where
+  (<>) :: Generically a -> Generically a -> Generically a
+  Generically a <> Generically b = Generically (to (from a <> from b :: Rep a ()))
+
+-- | @since 4.17.0.0
+instance (Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where
+  mempty :: Generically a
+  mempty = Generically (to (mempty :: Rep a ()))
+
+  mappend :: Generically a -> Generically a -> Generically a
+  mappend = (<>)
+
+-- | A type whose instances are defined generically, using the
+-- 'Generic1' representation. 'Generically1' is a higher-kinded
+-- version of 'Generically' that uses 'Generic'.
+--
+-- Generic instances can be derived for type constructors via
+-- @'Generically1' F@ using @-XDerivingVia@.
+--
+-- @
+-- {-# LANGUAGE DeriveGeneric      #-}
+-- {-# LANGUAGE DerivingStrategies #-}
+-- {-# LANGUAGE DerivingVia        #-}
+--
+-- import GHC.Generics (Generic)
+--
+-- data V4 a = V4 a a a a
+--   deriving stock (Functor, Generic1)
+--
+--   deriving Applicative
+--   via Generically1 V4
+-- @
+--
+-- This corresponds to 'Applicative' instances defined by pointwise
+-- lifting:
+--
+-- @
+-- instance Applicative V4 where
+--   pure :: a -> V4 a
+--   pure a = V4 a a a a
+--
+--   liftA2 :: (a -> b -> c) -> (V4 a -> V4 b -> V4 c)
+--   liftA2 (·) (V4 a1 b1 c1 d1) (V4 a2 b2 c2 d2) =
+--     V4 (a1 · a2) (b1 · b2) (c1 · c2) (d1 · d2)
+-- @
+--
+-- Historically this required modifying the type class to include
+-- generic method definitions (@-XDefaultSignatures@) and deriving it
+-- with the @anyclass@ strategy (@-XDeriveAnyClass@). Having a /via
+-- type/ like 'Generically1' decouples the instance from the type
+-- class.
+--
+-- @since 4.17.0.0
+type    Generically1 :: forall k. (k -> Type) -> (k -> Type)
+newtype Generically1 f a where
+  Generically1 :: forall {k} f a. f a -> Generically1 @k f a
+
+-- | @since 4.17.0.0
+instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where
+  fmap :: (a -> a') -> (Generically1 f a -> Generically1 f a')
+  fmap f (Generically1 as) = Generically1
+    (to1 (fmap f (from1 as)))
+
+  (<$) :: a -> Generically1 f b -> Generically1 f a
+  a <$ Generically1 as = Generically1
+    (to1 (a <$ from1 as))
+
+-- | @since 4.17.0.0
+instance (Generic1 f, Applicative (Rep1 f)) => Applicative (Generically1 f) where
+  pure :: a -> Generically1 f a
+  pure a = Generically1
+    (to1 (pure a))
+
+  (<*>) :: Generically1 f (a1 -> a2) -> Generically1 f a1 -> Generically1 f a2
+  Generically1 fs <*> Generically1 as = Generically1
+    (to1 (from1 fs <*> from1 as))
+
+  liftA2 :: (a1 -> a2 -> a3)
+         -> (Generically1 f a1 -> Generically1 f a2 -> Generically1 f a3)
+  liftA2 (·) (Generically1 as) (Generically1 bs) = Generically1
+    (to1 (liftA2 (·) (from1 as) (from1 bs)))
+
+-- | @since 4.17.0.0
+instance (Generic1 f, Alternative (Rep1 f)) => Alternative (Generically1 f) where
+  empty :: Generically1 f a
+  empty = Generically1
+    (to1 empty)
+
+  (<|>) :: Generically1 f a -> Generically1 f a -> Generically1 f a
+  Generically1 as1 <|> Generically1 as2 = Generically1
+    (to1 (from1 as1 <|> from1 as2))
+
+--------------------------------------------------------------------------------
 -- Meta-data
 --------------------------------------------------------------------------------
 
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 5515227821..c8a1611508 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -3,6 +3,10 @@
 ## 4.17.0.0 *TBA*
 
   * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`.
+  * Add `Generically` and `Generically1` to `GHC.Generics` for deriving generic
+    instances with `DerivingVia`. `Generically` instances include `Semigroup` and
+    `Monoid`. `Generically1` instances: `Functor`, `Applicative`, `Alternative`,
+    `Eq1` and `Ord1`.
 
   * Introduce `GHC.ExecutablePath.executablePath`, which is more robust than
     `getExecutablePath` in cases when the executable has been deleted.
@@ -91,7 +95,7 @@
   * Add `MonadFix` and `MonadZip` instances for `Complex`
 
   * Add `Ix` instances for tuples of size 6 through 15
-   
+
   * Correct `Bounded` instance and remove `Enum` and `Integral` instances for
     `Data.Ord.Down`.
 
diff --git a/testsuite/tests/generics/T19819.hs b/testsuite/tests/generics/T19819.hs
new file mode 100644
index 0000000000..f624008640
--- /dev/null
+++ b/testsuite/tests/generics/T19819.hs
@@ -0,0 +1,17 @@
+{-# Language DeriveGeneric #-}
+{-# Language DerivingStrategies #-}
+{-# Language DerivingVia #-}
+
+import GHC.Generics (Generic, Generically(..))
+
+data T = T [Int] [Int] [Int] [Int] [Int] [Int]
+ deriving
+ stock (Show, Generic)
+
+ deriving (Semigroup, Monoid)
+ via Generically T
+
+main :: IO ()
+main = do
+  print (mempty :: T)
+  print (T [1,2] [3] [] [4,5,6] [7] [8] <> T [10,20] [30] [] [40,50,60] [70] [80])
diff --git a/testsuite/tests/generics/T19819.stdout b/testsuite/tests/generics/T19819.stdout
new file mode 100644
index 0000000000..31a6d4b087
--- /dev/null
+++ b/testsuite/tests/generics/T19819.stdout
@@ -0,0 +1,2 @@
+T [] [] [] [] [] []
+T [1,2,10,20] [3,30] [] [4,5,6,40,50,60] [7,70] [8,80]
\ No newline at end of file
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index 4887d491cb..1fccfffc16 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -44,3 +44,4 @@ test('T10361b', normal, compile, [''])
 test('T11358', normal, compile_and_run, [''])
 test('T12220', normal, compile, [''])
 test('T15012', [extra_files(['T15012.hs', 'T15012a.hs'])], makefile_test, [])
+test('T19819', normal, compile_and_run, [''])
diff --git a/testsuite/tests/ghci/scripts/T12550.stdout b/testsuite/tests/ghci/scripts/T12550.stdout
index 05baf3e900..a0449406f1 100644
--- a/testsuite/tests/ghci/scripts/T12550.stdout
+++ b/testsuite/tests/ghci/scripts/T12550.stdout
@@ -36,6 +36,10 @@ instance Functor Par1 -- Defined in ‘GHC.Generics’
 instance ∀ i (c ∷ Meta) (f ∷ ★ → ★). Functor f ⇒ Functor (M1 i c f)
   -- Defined in ‘GHC.Generics’
 instance ∀ i c. Functor (K1 i c) -- Defined in ‘GHC.Generics’
+instance ∀ (f ∷ ★ → ★).
+         (Generic1 f, Functor (Rep1 f)) ⇒
+         Functor (Generically1 f)
+  -- Defined in ‘GHC.Generics’
 instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★).
          (Functor f, Functor g) ⇒
          Functor (f :.: g)