{-# LANGUAGE
  AllowAmbiguousTypes,
  ConstraintKinds,
  EmptyCase,
  FlexibleContexts,
  FlexibleInstances,
  MultiParamTypeClasses,
  QuantifiedConstraints,
  RankNTypes,
  ScopedTypeVariables,
  TypeApplications,
  TypeOperators,
  UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}

-- | This is an internal module. Look, don't touch.
--
-- "Generic.Functor" is the public API.

module Generic.Functor.Internal where

import ApNormalize
import Control.Applicative (liftA2)
import Data.Bifoldable (Bifoldable(..))
import Data.Bifunctor (Bifunctor(..))
import Data.Coerce (coerce, Coercible)
import Data.Functor.Identity (Identity(..))
import Data.Functor.Const (Const(..))
import Data.Monoid (Endo(..))
import GHC.Generics hiding (S)

import Generic.Functor.Internal.Implicit

-- | Generic implementation of 'fmap'. See also 'GenericFunctor' for @DerivingVia@,
-- using 'gfmap' under the hood.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('gfmap')
--
-- data Twice a = Twice (Either a a)
--   deriving 'Generic'
--
-- instance 'Functor' Twice where
--   'fmap' = 'gfmap'
-- @
--
-- Unlike 'gsolomap', 'gfmap' is safe to use in all contexts.
gfmap :: forall f a b. GFunctor f => (a -> b) -> (f a -> f b)
gfmap :: forall (f :: * -> *) a b. GFunctor f => (a -> b) -> f a -> f b
gfmap a -> b
f = forall (c :: Constraint) r. (c => r) -> c => r
with @(GFunctorRep a b f) (forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- | Generalized generic functor.
--
-- 'gsolomap' is a generalization of 'gfmap' (generic 'fmap'),
-- where the type parameter to be \"mapped\" does not have to be the last one.
--
-- 'gsolomap' is __unsafe__: misuse will break your programs.
-- Read the <#gsolomapusage Usage> section below for details.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('gsolomap')
--
-- data Result a r = Error a | Ok r  -- Another name for Either
--   deriving 'Generic'
--
-- mapError :: (a -> b) -> Result a r -> Result b r
-- mapError = 'gsolomap'
--
-- mapOk :: (r -> s) -> Result a r -> Result a s
-- mapOk = 'gsolomap'
--
-- mapBoth :: (a -> b) -> Result a a -> Result b b
-- mapBoth = 'gsolomap'
-- @
--
-- === Usage #gsolomapusage#
--
-- (This also applies to 'solomap', 'gmultimap', and 'multimap'.)
--
-- 'gsolomap' should only be used to define __polymorphic__ "@fmap@-like functions".
-- It works only in contexts where @a@ and @b@ are two distinct, non-unifiable
-- type variables. This is usually the case when they are bound by universal
-- quantification (@forall a b. ...@), with no equality constraints on @a@ and
-- @b@.
--
-- The one guarantee of 'gsolomap' is that @'gsolomap' 'id' = 'id'@.
-- Under the above conditions, that law and the types should uniquely determine
-- the implementation, which 'gsolomap' seeks automatically.
--
-- The unsafety is due to the use of incoherent instances as part of the
-- definition of 'GSolomap'. Functions are safe to specialize after 'GSolomap'
-- (and 'Solomap') constraints have been discharged.
--
-- Note also that the type parameters of 'gsolomap' must all be determined by
-- the context. For instance, composing two 'gsolomap', as in
-- @'gsolomap' f . 'gsolomap' g@, is a type error because the type in the middle
-- cannot be inferred.
gsolomap :: forall a b x y. (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y)
gsolomap :: forall a b x y.
(Generic x, Generic y, GSolomap a b x y) =>
(a -> b) -> x -> y
gsolomap a -> b
f = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | Generalized implicit functor.
--
-- Use this when @x@ and @y@ are applications of existing functors
-- ('Functor', 'Bifunctor').
--
-- This is a different use case from 'Generic.Functor.gfmap' and 'gsolomap', which make
-- functors out of freshly declared @data@ types.
--
-- 'solomap' is __unsafe__: misuse will break your programs.
--
-- See the <#gsolomapusage Usage> section of 'gsolomap' for details.
--
-- === Example
--
-- @
-- map1 :: (a -> b) -> Either e (Maybe [IO a]) -> Either e (Maybe [IO b])
-- map1 = 'solomap'
-- -- equivalent to:   fmap . fmap . fmap . fmap
--
-- map2 :: (a -> b) -> (e -> Either [a] r) -> (e -> Either [b] r)
-- map2 = 'solomap'
-- -- equivalent to:   \\f -> fmap (bimap (fmap f) id)
-- @
solomap :: forall a b x y. Solomap a b x y => (a -> b) -> (x -> y)
solomap :: forall a b x y. Solomap a b x y => (a -> b) -> x -> y
solomap a -> b
f = forall arr x y. Multimap arr x y => arr -> x -> y
multimap a -> b
f

-- | Generic n-ary functor.
--
-- A generalization of 'gsolomap' to map over multiple parameters simultaneously.
-- 'gmultimap' takes a list of functions separated by @(':+')@ and terminated by @()@.
--
-- 'gmultimap' is __unsafe__: misuse will break your programs.
-- The type of every function in the list must be some @(a -> b)@
-- where @a@ and @b@ are distinct type variables.
--
-- See the <#gsolomapusage Usage> section of 'gsolomap' for details.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('gmultimap')
--
-- data Three a b c = One a | Two b | Three c
--   deriving 'Generic'
--
-- mapThree :: (a -> a') -> (b -> b') -> (c -> c') -> Three a b c -> Three a' b' c'
-- mapThree f g h = 'gmultimap' (f ':+' g ':+' h ':+' ())
-- @
gmultimap :: forall arr x y. (Generic x, Generic y, GMultimap arr x y) => arr -> (x -> y)
gmultimap :: forall arr x y.
(Generic x, Generic y, GMultimap arr x y) =>
arr -> x -> y
gmultimap arr
f = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent arr
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | Implicit n-ary functor.
--
-- A generalization of 'solomap' to map over multiple parameters simultaneously.
-- 'multimap' takes a list of functions separated by @(':+')@ and terminated by @()@.
--
-- 'multimap' is __unsafe__: misuse will break your programs.
-- The type of every function in the list must be some @(a -> b)@
-- where @a@ and @b@ are distinct type variables.
--
-- See the <#gsolomapusage Usage> section of 'gsolomap' for details.
--
-- === Example
--
-- @
-- type F a b c = Either a (b, c)
--
-- map3 :: (a -> a') -> (b -> b') -> (c -> c') -> F a b c -> F a' b' c'
-- map3 f g h = 'multimap' (f ':+' g ':+' h ':+' ())
-- -- equivalent to:  \\f g h -> bimap f (bimap g h)
-- @
multimap :: forall arr x y. Multimap arr x y => arr -> (x -> y)
multimap :: forall arr x y. Multimap arr x y => arr -> x -> y
multimap arr
f = forall arr x y. MultimapI arr x y => arr -> x -> y
multimapI (forall arr. arr -> Default Incoherent arr
defaultIncoherent arr
f)

-- | Generic implementation of 'bimap' from 'Bifunctor'. See also 'GenericBifunctor'.
gbimap :: forall f a b c d. GBimap f => (a -> b) -> (c -> d) -> f a c -> f b d
gbimap :: forall (f :: * -> * -> *) a b c d.
GBimap f =>
(a -> b) -> (c -> d) -> f a c -> f b d
gbimap a -> b
f c -> d
g = forall (c :: Constraint) r. (c => r) -> c => r
with @(GBimapRep a b c d f) (forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent (a -> b
f forall a b. a -> b -> a :+ b
:+ c -> d
g)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- | Generic implementation of 'first' from 'Bifunctor'. See also 'GenericBifunctor'.
gfirst :: forall f a b c. GFirst f => (a -> b) -> f a c -> f b c
gfirst :: forall (f :: * -> * -> *) a b c.
GFirst f =>
(a -> b) -> f a c -> f b c
gfirst a -> b
f = forall (c :: Constraint) r. (c => r) -> c => r
with @(GFirstRep a b c f) (forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- | Generic implementation of 'second' from 'Bifunctor'. See also 'GenericBifunctor'.
gsecond :: forall f a c d. GSecond f => (c -> d) -> f a c -> f a d
gsecond :: forall (f :: * -> * -> *) a c d.
GSecond f =>
(c -> d) -> f a c -> f a d
gsecond = forall (f :: * -> *) a b. GFunctor f => (a -> b) -> f a -> f b
gfmap

-- *** Fold

-- | Generic implementation of 'foldMap' from 'Foldable'.
gfoldMap :: forall t m a. (GFoldMap m t, Monoid m) => (a -> m) -> t a -> m
gfoldMap :: forall (t :: * -> *) m a.
(GFoldMap m t, Monoid m) =>
(a -> m) -> t a -> m
gfoldMap a -> m
f =
  forall (c :: Constraint) r. (c => r) -> c => r
with @(GFoldMapRep a a m t) (forall m arr (f :: * -> *).
(GFoldMap1 m arr f f, Monoid m) =>
arr -> f () -> m
gfoldMapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent (forall m x y. (x -> m) -> Fold m x y
Fold @m @a @a a -> m
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- | Generic implementation of 'bifoldMap' from 'Bifoldable'.
gbifoldMap :: forall t m a b. (GBifoldMap m t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m
gbifoldMap :: forall (t :: * -> * -> *) m a b.
(GBifoldMap m t, Monoid m) =>
(a -> m) -> (b -> m) -> t a b -> m
gbifoldMap a -> m
f b -> m
g =
  forall (c :: Constraint) r. (c => r) -> c => r
with @(GBifoldMapRep a a b b m t) (forall m arr (f :: * -> *).
(GFoldMap1 m arr f f, Monoid m) =>
arr -> f () -> m
gfoldMapRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent (forall m x y. (x -> m) -> Fold m x y
Fold @m @a @a a -> m
f forall a b. a -> b -> a :+ b
:+ forall m x y. (x -> m) -> Fold m x y
Fold @m @b @b b -> m
g)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- *** Traverse

-- | Generic implementation of 'traverse' from 'Traversable'.
gtraverse :: forall t f a b. (GTraverse f t, Applicative f) => (a -> f b) -> t a -> f (t b)
gtraverse :: forall (t :: * -> *) (f :: * -> *) a b.
(GTraverse f t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse a -> f b
f = forall (c :: Constraint) r. (c => r) -> c => r
with @(GTraverseRep a b f t) (forall (f :: * -> *) a. Applicative f => Aps f a -> f a
lowerAps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GTraverse1 m arr f g =>
arr -> f () -> Aps m (g ())
gtraverseRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent a -> f b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)

-- | Generic implementation of 'bitraverse' from 'Bitraversable'.
gbitraverse :: forall t f a b c d. (GBitraverse f t, Applicative f) => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)
gbitraverse :: forall (t :: * -> * -> *) (f :: * -> *) a b c d.
(GBitraverse f t, Applicative f) =>
(a -> f b) -> (c -> f d) -> t a c -> f (t b d)
gbitraverse a -> f b
f c -> f d
g =
  forall (c :: Constraint) r. (c => r) -> c => r
with @(GBitraverseRep a b c d f t) (forall (f :: * -> *) a. Applicative f => Aps f a -> f a
lowerAps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GTraverse1 m arr f g =>
arr -> f () -> Aps m (g ())
gtraverseRep (forall arr. arr -> Default Incoherent arr
defaultIncoherent (a -> f b
f forall a b. a -> b -> a :+ b
:+ c -> f d
g)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from)


-- | Explicitly require a constraint, to force the instantiation of a quantified constraint.
with :: forall c r. (c => r) -> (c => r)
with :: forall (c :: Constraint) r. (c => r) -> c => r
with c => r
x = c => r
x

-- ** Top-level constraints

-- *** @gfmap@

-- | Generic 'Functor'. Constraint for 'gfmap'.
class    (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f
instance (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f

-- | Internal component of 'GFunctor'.
--
-- This is an example of the \"quantified constraints trick\" to encode
-- @forall a b. GMap1 a b (Rep (f a)) (Rep (f b))@ which doesn't actually
-- work as-is.
class    GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f
instance GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f

-- *** @gbimap@

-- | Constraint for 'gbimap'.
class    (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f
instance (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f

-- | Internal component of 'GBifunctor'.
class    GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f
instance GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f

-- *** @gfirst@

-- | Constraint for 'gfirst'.
class    (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f
instance (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f

-- | Internal component of 'GFirst'.
class    GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f
instance GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f

-- *** @gsecond@

-- | Constraint for 'gsecond'.
class    (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f
instance (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f

-- | Generic 'Bifunctor'.
class    (GBimap f, GFirst f, GSecond f) => GBifunctor f
instance (GBimap f, GFirst f, GSecond f) => GBifunctor f

-- *** @gtraverse@

-- | Constraint for 'gtraverse'.
class    (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t
instance (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t

class    GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t
instance GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t

-- | Generic 'Traversable'.
class    (forall f. Applicative f => GBitraverse f t) => GTraversable t
instance (forall f. Applicative f => GBitraverse f t) => GTraversable t

-- | Constraint for 'gtraverse'.
class    (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t
instance (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t

class    GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t
instance GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t

-- | Generic 'Bitraversable'.
class    (forall f. Applicative f => GBitraverse f t) => GBitraversable t
instance (forall f. Applicative f => GBitraverse f t) => GBitraversable t

-- *** @foldMap@

-- | Constraint for 'gfoldMap'.
class    (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t
instance (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t

class    GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t
instance GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t

-- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable').
class    (forall m. Monoid m => GFoldMap m t) => GFoldable t
instance (forall m. Monoid m => GFoldMap m t) => GFoldable t

-- | Constraint for 'gbifoldMap'.
class    (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t
instance (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t

class    GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t
instance GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t

-- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable').
class    (forall m. Monoid m => GBifoldMap m t) => GBifoldable t
instance (forall m. Monoid m => GBifoldMap m t) => GBifoldable t

-- *** Others

-- | Constraint for 'gsolomap'.
class    GMultimap (a -> b) x y => GSolomap a b x y
instance GMultimap (a -> b) x y => GSolomap a b x y

-- | Constraint for 'solomap'.
class    Multimap (a -> b) x y => Solomap a b x y
instance Multimap (a -> b) x y => Solomap a b x y

-- | Constraint for 'gmultimap'.
class    GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y
instance GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y

-- | Constraint for 'multimap'.
class    MultimapI (Default Incoherent arr) x y => Multimap arr x y
instance MultimapI (Default Incoherent arr) x y => Multimap arr x y

-- * Deriving Via

-- ** Functor

-- | @newtype@ for @DerivingVia@ of 'Functor' and 'Foldable' instances.
--
-- Note: the GHC extensions @DeriveFunctor@, @DeriveFoldable@, and @DeriveTraversable@
-- (which implies all three) already works out-of-the-box in most cases.
-- There are exceptions, such as the following example.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-}
--
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('GenericFunctor'(..))
--
-- data Twice a = Twice (Either a a)
--   deriving 'Generic'
--   deriving ('Functor', 'Foldable') via ('GenericFunctor' Twice)
-- @
newtype GenericFunctor f a = GenericFunctor (f a)

instance GFunctor f => Functor (GenericFunctor f) where
  fmap :: forall a b. (a -> b) -> GenericFunctor f a -> GenericFunctor f b
fmap = forall s t r. Coercible s t => (r -> s) -> r -> t
coerce1 (forall (f :: * -> *) a b. GFunctor f => (a -> b) -> f a -> f b
gfmap @f)

instance GFoldable f => Foldable (GenericFunctor f) where
  foldMap :: forall m a. Monoid m => (a -> m) -> GenericFunctor f a -> m
foldMap = forall t u am m. Coercible t u => (am -> t -> m) -> am -> u -> m
coerceFoldMap (forall (t :: * -> *) m a.
(GFoldMap m t, Monoid m) =>
(a -> m) -> t a -> m
gfoldMap @f)

-- ** Bifunctor

-- | @newtype@ for @DerivingVia@ of 'Bifunctor' and 'Bifoldable' instances.
--
-- Note: although 'GenericBifunctor' has 'Functor' and 'Foldable' instances,
-- it is recommended to use 'GenericFunctor' instead for those two classes.
-- They have to use a separate deriving clause from 'Bifunctor' and 'Bifoldable' anyway.
-- Those instances exist because they are to become superclasses of 'Bifunctor'
-- and 'Bifoldable'. The 'Foldable' instance of 'GenericBifunctor' is also less
-- efficient than 'GenericFunctor' unless the extra @const mempty@ gets optimized away.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-}
--
-- import "Data.Bifoldable" ('Bifoldable')
-- import "Data.Bifunctor" ('Bifunctor')
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('GenericFunctor'(..), 'GenericBifunctor'(..))
--
-- data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b
--   deriving 'Generic'
--   deriving ('Functor', 'Foldable') via ('GenericFunctor' (Tree a))
--   deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' Tree)
--
-- data CofreeF f a b = a :< f b
--   deriving 'Generic'
--   deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' (CofreeF f))
-- @
newtype GenericBifunctor f a b = GenericBifunctor (f a b)

instance GBifunctor f => Bifunctor (GenericBifunctor f) where
  bimap :: forall a b c d.
(a -> b)
-> (c -> d) -> GenericBifunctor f a c -> GenericBifunctor f b d
bimap = forall t u r s. Coercible t u => (r -> s -> t) -> r -> s -> u
coerce2 (forall (f :: * -> * -> *) a b c d.
GBimap f =>
(a -> b) -> (c -> d) -> f a c -> f b d
gbimap @f)
  first :: forall a b c.
(a -> b) -> GenericBifunctor f a c -> GenericBifunctor f b c
first = forall w v (f :: * -> * -> *) b d (g :: * -> * -> *) r.
(Coercible w v, Coercible (f b d) (g b d)) =>
(r -> w -> f b d) -> r -> v -> g b d
coerce3 (forall (f :: * -> * -> *) a b c.
GFirst f =>
(a -> b) -> f a c -> f b c
gfirst @f)
  second :: forall b c a.
(b -> c) -> GenericBifunctor f a b -> GenericBifunctor f a c
second = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

instance GBifoldable f => Bifoldable (GenericBifunctor f) where
  bifoldMap :: forall m a b.
Monoid m =>
(a -> m) -> (b -> m) -> GenericBifunctor f a b -> m
bifoldMap = forall t u am bm m.
Coercible t u =>
(am -> bm -> t -> m) -> am -> bm -> u -> m
coerceBifoldMap (forall (t :: * -> * -> *) m a b.
(GBifoldMap m t, Monoid m) =>
(a -> m) -> (b -> m) -> t a b -> m
gbifoldMap @f)

instance GSecond f => Functor (GenericBifunctor f a) where
  fmap :: forall a b.
(a -> b) -> GenericBifunctor f a a -> GenericBifunctor f a b
fmap = forall w v (f :: * -> * -> *) b d (g :: * -> * -> *) r.
(Coercible w v, Coercible (f b d) (g b d)) =>
(r -> w -> f b d) -> r -> v -> g b d
coerce3 (forall (f :: * -> * -> *) a c d.
GSecond f =>
(c -> d) -> f a c -> f a d
gsecond @f)

instance GBifoldable f => Foldable (GenericBifunctor f a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> GenericBifunctor f a a -> m
foldMap = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)

-- ** Internal coercions

coerce1 :: Coercible s t => (r -> s) -> (r -> t)
coerce1 :: forall s t r. Coercible s t => (r -> s) -> r -> t
coerce1 = coerce :: forall a b. Coercible a b => a -> b
coerce

coerce2 :: Coercible t u => (r -> s -> t) -> (r -> s -> u)
coerce2 :: forall t u r s. Coercible t u => (r -> s -> t) -> r -> s -> u
coerce2 = coerce :: forall a b. Coercible a b => a -> b
coerce

coerce3 :: (Coercible w v, Coercible (f b d) (g b d)) => (r -> w -> f b d) -> (r -> v -> g b d)
coerce3 :: forall w v (f :: * -> * -> *) b d (g :: * -> * -> *) r.
(Coercible w v, Coercible (f b d) (g b d)) =>
(r -> w -> f b d) -> r -> v -> g b d
coerce3 = coerce :: forall a b. Coercible a b => a -> b
coerce

coerceFoldMap :: Coercible t u => (am -> t -> m) -> (am -> u -> m)
coerceFoldMap :: forall t u am m. Coercible t u => (am -> t -> m) -> am -> u -> m
coerceFoldMap = coerce :: forall a b. Coercible a b => a -> b
coerce

coerceBifoldMap :: Coercible t u => (am -> bm -> t -> m) -> (am -> bm -> u -> m)
coerceBifoldMap :: forall t u am bm m.
Coercible t u =>
(am -> bm -> t -> m) -> am -> bm -> u -> m
coerceBifoldMap = coerce :: forall a b. Coercible a b => a -> b
coerce

-- ** @GMultimapK@

-- | We use the same class to implement all of 'fmap', 'foldMap', 'traverse',
-- instantiating @m@ as 'Identity', 'Const (EndoM mm)' and 'Aps n' respectively.
-- Those three cases differ in their instances for 'K1'.
--
-- (the K stands for @Kleisli@, because the result is @Kleisli m (f ()) (g ())@
class GMultimapK m arr f g where
  gmultimapK :: arr -> f () -> m (g ())

-- *** Instance for @fmap@

instance MultimapI arr x y => GMultimapK Identity arr (K1 i x) (K1 i' y) where
  gmultimapK :: arr -> K1 i x () -> Identity (K1 i' y ())
gmultimapK = coerce :: forall a b. Coercible a b => a -> b
coerce (forall arr x y. MultimapI arr x y => arr -> x -> y
multimapI @arr @x @y)

class    GMultimapK Identity arr f g => GMap1 arr f g
instance GMultimapK Identity arr f g => GMap1 arr f g

gmapRep :: GMap1 arr f g => arr -> f () -> g ()
gmapRep :: forall arr (f :: * -> *) (g :: * -> *).
GMap1 arr f g =>
arr -> f () -> g ()
gmapRep arr
f f ()
x = forall a. Identity a -> a
runIdentity (forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f ()
x)

-- *** Instance for @foldMap@

instance (Multifold_ m arr x y, Monoid m) => GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i' y) where
  gmultimapK :: arr -> K1 i x () -> Const (EndoM m) (K1 i' y ())
gmultimapK arr
f (K1 x
x) = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m x y. Monoid m => Fold m x y -> x -> Const (EndoM m) y
foldToConst (forall m arr x y. Multifold_ m arr x y => arr -> Fold m x y
multifold_ arr
f) x
x

-- Spooky instance. It makes sense only because @GMultimapK (Const (EndoM m))@
-- occurs exclusively under a quantified constraint (in the definition of GFoldMap).
instance {-# INCOHERENT #-} GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i x) where
  gmultimapK :: arr -> K1 i x () -> Const (EndoM m) (K1 i x ())
gmultimapK arr
_ (K1 x
_) = forall {k} a (b :: k). a -> Const a b
Const (forall a. (a -> a) -> Endo a
Endo forall a. a -> a
id)

-- An extra wrapper to simplify away @(mempty <> _)@ and @(_ <> mempty)@.
type EndoM m = Endo (Maybe m)

unEndoM :: Monoid m => EndoM m -> m
unEndoM :: forall m. Monoid m => EndoM m -> m
unEndoM (Endo Maybe m -> Maybe m
f) = case Maybe m -> Maybe m
f forall a. Maybe a
Nothing of
  Maybe m
Nothing -> forall a. Monoid a => a
mempty
  Just m
y -> m
y

liftEndoM :: Monoid m => m -> EndoM m
liftEndoM :: forall m. Monoid m => m -> EndoM m
liftEndoM m
y = forall a. (a -> a) -> Endo a
Endo (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe m -> m
app)
  where
    app :: Maybe m -> m
app Maybe m
Nothing = m
y
    app (Just m
y') = m
y forall a. Monoid a => a -> a -> a
`mappend` m
y'

foldToConst :: Monoid m => Fold m x y -> x -> Const (EndoM m) y
foldToConst :: forall m x y. Monoid m => Fold m x y -> x -> Const (EndoM m) y
foldToConst (Fold x -> m
f) x
x = forall {k} a (b :: k). a -> Const a b
Const (forall m. Monoid m => m -> EndoM m
liftEndoM (x -> m
f x
x))

class    GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g
instance GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g

-- | Danger! @GFoldMap1 m arr f f@ MUST come from a quantified constraint (see use in 'gfoldMap').
gfoldMapRep :: forall m arr f. (GFoldMap1 m arr f f, Monoid m) => arr -> f () -> m
gfoldMapRep :: forall m arr (f :: * -> *).
(GFoldMap1 m arr f f, Monoid m) =>
arr -> f () -> m
gfoldMapRep arr
f f ()
x = forall m. Monoid m => EndoM m -> m
unEndoM (forall {k} a (b :: k). Const a b -> a
getConst (forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f ()
x :: Const (EndoM m) (f ())))

-- *** Instance for @traverse@

instance (Multitraverse m arr x y) => GMultimapK (Aps m) arr (K1 i x) (K1 i' y) where
  gmultimapK :: arr -> K1 i x () -> Aps m (K1 i' y ())
gmultimapK arr
f (K1 x
x) = forall k i c (p :: k). c -> K1 i c p
K1 forall a b (f :: * -> *). (a -> b) -> f a -> Aps f b
<$>^ forall (f :: * -> *) arr x y.
Multitraverse f arr x y =>
arr -> x -> f y
multitraverse arr
f x
x

class    GMultimapK (Aps m) arr f g => GTraverse1 m arr f g
instance GMultimapK (Aps m) arr f g => GTraverse1 m arr f g

gtraverseRep :: GTraverse1 m arr f g => arr -> f () -> Aps m (g ())
gtraverseRep :: forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GTraverse1 m arr f g =>
arr -> f () -> Aps m (g ())
gtraverseRep = forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK

-- *** Common instances

instance (GMultimapK m arr f g, Functor m) => GMultimapK m arr (M1 i c f) (M1 i' c' g) where
  gmultimapK :: arr -> M1 i c f () -> m (M1 i' c' g ())
gmultimapK arr
f (M1 f ()
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f ()
x

instance
  (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) =>
  GMultimapK m arr (f1 :+: f2) (g1 :+: g2)
  where
  gmultimapK :: arr -> (:+:) f1 f2 () -> m ((:+:) g1 g2 ())
gmultimapK arr
f (L1 f1 ()
x) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f1 ()
x
  gmultimapK arr
f (R1 f2 ()
y) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f2 ()
y

instance
  (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) =>
  GMultimapK m arr (f1 :*: f2) (g1 :*: g2)
  where
  gmultimapK :: arr -> (:*:) f1 f2 () -> m ((:*:) g1 g2 ())
gmultimapK arr
f (f1 ()
x :*: f2 ()
y) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f1 ()
x) (forall (m :: * -> *) arr (f :: * -> *) (g :: * -> *).
GMultimapK m arr f g =>
arr -> f () -> m (g ())
gmultimapK arr
f f2 ()
y)

instance Applicative m => GMultimapK m arr U1 U1 where
  gmultimapK :: arr -> U1 () -> m (U1 ())
gmultimapK arr
_ U1 ()
U1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance GMultimapK m arr V1 V1 where
  gmultimapK :: arr -> V1 () -> m (V1 ())
gmultimapK arr
_ V1 ()
v = case V1 ()
v of