-- |
-- Module      : Generics.Deriving.Default
-- Description : Default implementations of generic classes
-- License     : BSD-3-Clause
--
-- Maintainer  : generics@haskell.org
-- Stability   : experimental
-- Portability : non-portable
--
-- GHC 8.6 introduced the
-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@
-- language extension, which means a typeclass instance can be derived from
-- an existing instance for an isomorphic type. Any newtype is isomorphic
-- to the underlying type. By implementing a typeclass once for the newtype,
-- it is possible to derive any typeclass for any type with a 'Generic' instance.
--
-- For a number of classes, there are sensible default instantiations. In
-- older GHCs, these can be supplied in the class definition, using the
-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=defaultsignatures#extension-DefaultSignatures DefaultSignatures>@
-- extension. However, only one default can be provided! With
-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@
-- it is now possible to choose from many
-- default instantiations.
--
-- This package contains a number of such classes. This module demonstrates
-- how one might create a family of newtypes ('Default', 'Default1') for
-- which such instances are defined.
--
-- One might then use
-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@
-- as follows. The implementations of the data types are elided here (they
-- are irrelevant). For most cases, either the deriving clause with the
-- data type definition or the standalone clause will work (for some types
-- it is necessary to supply the context explicitly using the latter form).
-- See the source of this module for the implementations of instances for
-- the 'Default' family of newtypes and the source of the test suite for
-- some types which derive instances via these wrappers.

{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
# if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

module Generics.Deriving.Default
  ( -- * Kind @*@ (aka @Type@)

    -- $default

    Default(..)

  , -- * Kind @* -> *@ (aka @Type -> Type@)

    -- $default1

    Default1(..)

    -- * Other kinds

    -- $other-kinds
  ) where

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative ((<$>))
#endif
import Control.Monad (liftM)

import Generics.Deriving.Base
import Generics.Deriving.Copoint
import Generics.Deriving.Enum
import Generics.Deriving.Eq
import Generics.Deriving.Foldable
import Generics.Deriving.Functor
import Generics.Deriving.Monoid
import Generics.Deriving.Semigroup
import Generics.Deriving.Show
import Generics.Deriving.Traversable
import Generics.Deriving.Uniplate

-- $default
--
-- For classes which take an argument of kind 'Data.Kind.Type', use
-- 'Default'. An example of this class from @base@ would be 'Eq', or
-- 'Generic'.
--
-- These examples use 'GShow' and 'GEq'; they are interchangeable.
--
-- @
-- data MyType = …
--  deriving ('Generic')
--  deriving ('GEq') via ('Default' MyType)
--
-- deriving via ('Default' MyType) instance 'GShow' MyType
-- @
--
-- Instances may be parameterized by type variables.
--
-- @
-- data MyType1 a = …
--  deriving ('Generic')
--  deriving ('GShow') via ('Default' (MyType1 a))
--
-- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a)
-- @
--
-- These types both require instances for 'Generic'. This is because the
-- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic'
-- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic'
-- instance. For these two types, that means instances for @'Generic' MyType@
-- and @'Generic' (MyType1 a)@ respectively.
--
-- It also means the 'Generic' instance is not needed when there is already
-- a generic instance for the type used to derive the relevant instances.
-- For an example, see the documentation of the 'GShow' instance for
-- 'Default', below.

-- | This newtype wrapper can be used to derive default instances for
-- classes taking an argument of kind 'Data.Kind.Type'.
newtype Default a = Default { Default a -> a
unDefault :: a }

-- $default1
--
-- For classes which take an argument of kind @'Data.Kind.Type' ->
-- 'Data.Kind.Type'@, use 'Default1'.  An example of this class from @base@
-- would be 'Data.Functor.Classes.Eq1', or 'Generic1'.
--
-- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@.
--
-- @
-- data MyType1 a = …
--  deriving ('Generic1')
--  deriving ('GFunctor') via ('Default1' MyType1)
--
-- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1
-- @
--
-- Note that these instances require a @'Generic1' MyType1@ constraint as
-- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the
-- implementations for @'Default1' a@.

-- | This newtype wrapper can be used to derive default instances for
-- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@.
newtype Default1 f a = Default1 { Default1 f a -> f a
unDefault1 :: f a }

-- $other-kinds
--
-- These principles extend to classes taking arguments of other kinds.

--------------------------------------------------------------------------------
-- Eq
--------------------------------------------------------------------------------

instance (Generic a, GEq' (Rep a)) => GEq (Default a) where
  -- geq :: Default a -> Default a -> Bool
  Default a
x geq :: Default a -> Default a -> Bool
`geq` Default a
y = a
x a -> a -> Bool
forall a. (Generic a, GEq' (Rep a)) => a -> a -> Bool
`geqdefault` a
y

--------------------------------------------------------------------------------
-- Enum
--------------------------------------------------------------------------------

-- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and
-- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault'
-- and 'fromEnumDefault'.
instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where
  -- genum :: [Default a]
  genum :: [Default a]
genum = a -> Default a
forall a. a -> Default a
Default (a -> Default a) -> (Rep a Any -> a) -> Rep a Any -> Default a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> Default a) -> [Rep a Any] -> [Default a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rep a Any]
forall k (f :: k -> *) (a :: k). Enum' f => [f a]
enum'

--------------------------------------------------------------------------------
-- Show
--------------------------------------------------------------------------------

-- | For example, with this type:
--
-- @
-- newtype TestShow = TestShow 'Bool'
--   deriving ('GShow') via ('Default' 'Bool')
-- @
--
-- 'gshow' for @TestShow@ would produce the same string as `gshow` for
-- 'Bool'.
--
-- In this example, @TestShow@ requires no 'Generic' instance, as the
-- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@.
--
-- In general, when using a newtype wrapper, the instance can be derived
-- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default'
-- TestShow@).
instance (Generic a, GShow' (Rep a)) => GShow (Default a) where
  -- gshowsPrec :: Int -> Default a -> ShowS
  gshowsPrec :: Int -> Default a -> ShowS
gshowsPrec Int
n (Default a
x) = Int -> a -> ShowS
forall a. (Generic a, GShow' (Rep a)) => Int -> a -> ShowS
gshowsPrecdefault Int
n a
x

--------------------------------------------------------------------------------
-- Semigroup
--------------------------------------------------------------------------------

-- | Semigroups often have many sensible implementations of
-- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default.
-- Indeed, there is no 'GSemigroup'' instance for representations of sum
-- types.
--
-- In other cases, one may wish to use the existing wrapper newtypes in
-- @base@, such as the following (using 'Data.Semigroup.First'):
--
-- @
-- newtype FirstSemigroup = FirstSemigroup 'Bool'
--   deriving stock ('Eq', 'Show')
--   deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool')
-- @
--
instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where
  -- gsappend :: Default a -> Default a -> Default a
  Default a
x gsappend :: Default a -> Default a -> Default a
`gsappend` Default a
y = a -> Default a
forall a. a -> Default a
Default (a -> Default a) -> a -> Default a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. (Generic a, GSemigroup' (Rep a)) => a -> a -> a
`gsappenddefault` a
y

--------------------------------------------------------------------------------
-- Monoid
--------------------------------------------------------------------------------

instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where
  -- gmempty :: Default a
  gmempty :: Default a
gmempty = a -> Default a
forall a. a -> Default a
Default a
forall a. (Generic a, GMonoid' (Rep a)) => a
gmemptydefault

  -- gmappend :: Default a -> Default a -> Default a
  Default a
x gmappend :: Default a -> Default a -> Default a
`gmappend` Default a
y = a -> Default a
forall a. a -> Default a
Default (a -> Default a) -> a -> Default a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. (Generic a, GMonoid' (Rep a)) => a -> a -> a
`gmappenddefault` a
y

--------------------------------------------------------------------------------
-- Uniplate
--------------------------------------------------------------------------------

instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where

  -- children   ::                                             Default a  ->   [Default a]
  -- context    ::                             Default a   -> [Default a] ->    Default a
  -- descend    ::            (Default a ->    Default a)  ->  Default a  ->    Default a
  -- descendM   :: Monad m => (Default a -> m (Default a)) ->  Default a  -> m (Default a)
  -- transform  ::            (Default a ->    Default a)  ->  Default a  ->    Default a
  -- transformM :: Monad m => (Default a -> m (Default a)) ->  Default a  -> m (Default a)

  children :: Default a -> [Default a]
children     (Default a
x)    =       a -> Default a
forall a. a -> Default a
Default (a -> Default a) -> [a] -> [Default a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
forall a. (Generic a, Uniplate' (Rep a) a) => a -> [a]
childrendefault    a
x
  context :: Default a -> [Default a] -> Default a
context      (Default a
x) [Default a]
ys =       a -> Default a
forall a. a -> Default a
Default  (a -> Default a) -> a -> Default a
forall a b. (a -> b) -> a -> b
$  a -> [a] -> a
forall a. (Generic a, Context' (Rep a) a) => a -> [a] -> a
contextdefault     a
x    (Default a -> a
forall a. Default a -> a
unDefault (Default a -> a) -> [Default a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Default a]
ys)
  descend :: (Default a -> Default a) -> Default a -> Default a
descend    Default a -> Default a
f (Default a
x)    =       a -> Default a
forall a. a -> Default a
Default  (a -> Default a) -> a -> Default a
forall a b. (a -> b) -> a -> b
$  (a -> a) -> a -> a
forall a. (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
descenddefault          (Default a -> a
forall a. Default a -> a
unDefault (Default a -> a) -> (a -> Default a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Default a -> Default a
f (Default a -> Default a) -> (a -> Default a) -> a -> Default a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Default a
forall a. a -> Default a
Default) a
x
  descendM :: (Default a -> m (Default a)) -> Default a -> m (Default a)
descendM   Default a -> m (Default a)
f (Default a
x)    = (a -> Default a) -> m a -> m (Default a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Default a
forall a. a -> Default a
Default  (m a -> m (Default a)) -> m a -> m (Default a)
forall a b. (a -> b) -> a -> b
$  (a -> m a) -> a -> m a
forall a (m :: * -> *).
(Generic a, Uniplate' (Rep a) a, Monad m) =>
(a -> m a) -> a -> m a
descendMdefault   ((Default a -> a) -> m (Default a) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Default a -> a
forall a. Default a -> a
unDefault (m (Default a) -> m a) -> (a -> m (Default a)) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Default a -> m (Default a)
f (Default a -> m (Default a))
-> (a -> Default a) -> a -> m (Default a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Default a
forall a. a -> Default a
Default) a
x
  transform :: (Default a -> Default a) -> Default a -> Default a
transform  Default a -> Default a
f (Default a
x)    =       a -> Default a
forall a. a -> Default a
Default  (a -> Default a) -> a -> Default a
forall a b. (a -> b) -> a -> b
$  (a -> a) -> a -> a
forall a. (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
transformdefault        (Default a -> a
forall a. Default a -> a
unDefault (Default a -> a) -> (a -> Default a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Default a -> Default a
f (Default a -> Default a) -> (a -> Default a) -> a -> Default a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Default a
forall a. a -> Default a
Default) a
x
  transformM :: (Default a -> m (Default a)) -> Default a -> m (Default a)
transformM Default a -> m (Default a)
f (Default a
x)    = (a -> Default a) -> m a -> m (Default a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Default a
forall a. a -> Default a
Default  (m a -> m (Default a)) -> m a -> m (Default a)
forall a b. (a -> b) -> a -> b
$  (a -> m a) -> a -> m a
forall a (m :: * -> *).
(Generic a, Uniplate' (Rep a) a, Monad m) =>
(a -> m a) -> a -> m a
transformMdefault ((Default a -> a) -> m (Default a) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Default a -> a
forall a. Default a -> a
unDefault (m (Default a) -> m a) -> (a -> m (Default a)) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Default a -> m (Default a)
f (Default a -> m (Default a))
-> (a -> Default a) -> a -> m (Default a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Default a
forall a. a -> Default a
Default) a
x

--------------------------------------------------------------------------------
-- Functor
--------------------------------------------------------------------------------

instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where
  -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b
  gmap :: (a -> b) -> Default1 f a -> Default1 f b
gmap a -> b
f (Default1 f a
fx) = f b -> Default1 f b
forall (f :: * -> *) a. f a -> Default1 f a
Default1 (f b -> Default1 f b) -> f b -> Default1 f b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> f a -> f b
forall (f :: * -> *) a b.
(Generic1 f, GFunctor' (Rep1 f)) =>
(a -> b) -> f a -> f b
gmapdefault a -> b
f f a
fx

--------------------------------------------------
-- Copoint
--------------------------------------------------

instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where
  -- gcopoint :: Default1 f a -> a
  gcopoint :: Default1 f a -> a
gcopoint = f a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault (f a -> a) -> (Default1 f a -> f a) -> Default1 f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Default1 f a -> f a
forall (f :: * -> *) a. Default1 f a -> f a
unDefault1

--------------------------------------------------
-- Foldable
--------------------------------------------------

instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where
  -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m
  gfoldMap :: (a -> m) -> Default1 t a -> m
gfoldMap a -> m
f (Default1 t a
tx) = (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Generic1 t, GFoldable' (Rep1 t), Monoid m) =>
(a -> m) -> t a -> m
gfoldMapdefault a -> m
f t a
tx

--------------------------------------------------
-- Traversable
--------------------------------------------------

instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where
  -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b)
  gtraverse :: (a -> f b) -> Default1 t a -> f (Default1 t b)
gtraverse a -> f b
f (Default1 t a
fx) = t b -> Default1 t b
forall (f :: * -> *) a. f a -> Default1 f a
Default1 (t b -> Default1 t b) -> f (t b) -> f (Default1 t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault a -> f b
f t a
fx