{-# 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 Data.Bifunctor
import Data.Coerce
import GHC.Generics hiding (S)

-- | Generic implementation of 'fmap'. See also 'DeriveFunctor' 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 f = with @(GFunctorRep a b f) (to . gmap1 (f :+ ()) . 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.
gsolomap :: forall a b x y. (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y)
gsolomap f = to . gmap1 (f :+ ()) . from

-- | Generalized implicit functor.
--
-- Use this when @x@ and @y@ are applications of existing functors
-- ('Functor', 'Bifunctor').
--
-- This is a different use case from '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 f = multimap (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 f = to . gmap1 f . 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 f = multimap_ (s2 f)

-- | Generic implementation of 'bimap'. See also 'DeriveBifunctor'.
gbimap :: forall f a b c d. GBifunctor f => (a -> b) -> (c -> d) -> f a c -> f b d
gbimap f g = with @(GBifunctorRep a b c d f) (to . gmap1 (f :+ g :+ ()) . from)

-- | Generic implementation of 'first'. See also 'DeriveBifunctor'.
gfirst :: forall f a b c. GFirst f => (a -> b) -> f a c -> f b c
gfirst f = with @(GFirstRep a b c f) (to . gmap1 (f :+ ()) . from)

-- | Generic implementation of 'second'. See also 'DeriveBifunctor'.
gsecond :: forall f a c d. GSecond f => (c -> d) -> f a c -> f a d
gsecond = gfmap

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

-- ** Top-level constraints

-- *** @gfmap@

-- | 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 ((a -> b) :+ ()) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f
instance GMap1 ((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. GBifunctorRep a b c d f) => GBifunctor f
instance (forall a c. Generic (f a c), forall a b c d. GBifunctorRep a b c d f) => GBifunctor f

-- | Internal component of 'GBifunctor'.
class    GMap1 ((a -> b) :+ (c -> d) :+ ()) (Rep (f a c)) (Rep (f b d)) => GBifunctorRep a b c d f
instance GMap1 ((a -> b) :+ (c -> d) :+ ()) (Rep (f a c)) (Rep (f b d)) => GBifunctorRep 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 ((a -> b) :+ ()) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f
instance GMap1 ((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

-- *** Others

-- | Constraint for 'gsolomap'.
class    GMap1 ((a -> b) :+ ()) (Rep x) (Rep y) => GSolomap a b x y
instance GMap1 ((a -> b) :+ ()) (Rep x) (Rep 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 arr (Rep x) (Rep y) => GMultimap arr x y
instance GMap1 arr (Rep x) (Rep y) => GMultimap arr x y

-- | Constraint for 'multimap'.
class    Multimap_ (S2 arr) x y => Multimap arr x y
instance Multimap_ (S2 arr) x y => Multimap arr x y

-- * Deriving Via

-- ** Functor

-- | @newtype@ for @DerivingVia@ of 'Functor' instances.
--
-- Note: the GHC extension @DeriveFunctor@ 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" ('DeriveFunctor'(..))
--
-- data Twice a = Twice (Either a a)
--   deriving 'Generic'
--   deriving 'Functor' via ('DeriveFunctor' Twice)
-- @
newtype DeriveFunctor f a = DeriveFunctor (f a)

instance GFunctor f => Functor (DeriveFunctor f) where
  fmap = coerce1 (gfmap @f)

-- ** Bifunctor

-- | @newtype@ for @DerivingVia@ of 'Bifunctor' instances.
--
-- Note: deriving 'Bifunctor' for a generic type often requires 'Functor'
-- instances for types mentioned in the fields.
--
-- === Example
--
-- @
-- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-}
--
-- import "GHC.Generics" ('Generic')
-- import "Generic.Functor" ('DeriveFunctor'(..), 'DeriveBifunctor'(..))
--
-- data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b
--   deriving 'Generic'
--   deriving 'Functor' via ('DeriveFunctor' (Tree a))
--   deriving 'Bifunctor' via ('DeriveBifunctor' Tree)
--
-- data CofreeF f a b = a :< f b
--   deriving 'Generic'
--   deriving 'Bifunctor' via ('DeriveBifunctor' (CofreeF f))
-- @
newtype DeriveBifunctor f a b = DeriveBifunctor (f a b)

instance (GBifunctor f, GFirst f, GSecond f) => Bifunctor (DeriveBifunctor f) where
  bimap = coerce2 (gbimap @f)
  first = coerce3 (gfirst @f)
  second = coerce3 (gsecond @f)

-- ** Internal coercions

coerce1 :: Coercible s t => (r -> s) -> (r -> t)
coerce1 = coerce

coerce2 :: Coercible t u => (r -> s -> t) -> (r -> s -> u)
coerce2 = coerce

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

--

class GMap1 arr f g where
  gmap1 :: arr -> f () -> g ()

instance GMap1 arr f g => GMap1 arr (M1 i c f) (M1 i' c'' g) where
  gmap1 = coerce (gmap1 @arr @f @g)

instance (GMap1 arr f1 g1, GMap1 arr f2 g2) => GMap1 arr (f1 :+: f2) (g1 :+: g2) where
  gmap1 f (L1 x) = L1 (gmap1 f x)
  gmap1 f (R1 x) = R1 (gmap1 f x)

instance (GMap1 arr f1 g1, GMap1 arr f2 g2) => GMap1 arr (f1 :*: f2) (g1 :*: g2) where
  gmap1 f (x :*: y) = gmap1 f x :*: gmap1 f y

instance GMap1 arr U1 U1 where
  gmap1 _ U1 = U1

instance GMap1 arr V1 V1 where
  gmap1 _ v = case v of {}

instance Multimap arr x y => GMap1 arr (K1 i x) (K1 i' y) where
  gmap1 = coerce (multimap @arr @x @y)

-- | Internal implementation of 'Solomap'.
class Multimap_ arr x y where
  multimap_ :: arr -> x -> y

-- | Heterogeneous lists of arrows are constructed as lists separated by
-- @(':+')@ and terminated by @()@.
--
-- === Example
--
-- Given @f :: a -> a'@ and @g :: b -> b'@,
-- @(f ':+' g ':+' ())@ is a list with the two elements @f@ and @g@.
--
-- @
-- if
--   f :: a -> a'
--   g :: b -> b'
--
-- then
--   f ':+' g ':+' ()  ::  (a -> a') ':+' (b -> b') ':+' ()
-- @
--
-- Those lists are used by 'gmultimap' and 'multimap'.
--
-- @
-- bimap_ :: (a -> a') -> (b -> b') -> (Maybe a, [Either b a]) -> (Maybe a', [Either b' a'])
-- bimap_ f g = 'multimap' (f ':+' g ':+' ())
-- @
data a :+ b = a :+ b
infixr 1 :+

-- | @arr@ is the list of arrows provided by the user. It is constant.
-- When testing whether any arrow matches, @arr'@ is the remaining list of
-- arrows to be tested.
data S arr arr' = S arr arr'

type S2 arr = S arr arr

s2 :: arr -> S2 arr
s2 f = S f f

instance {-# INCOHERENT #-} Multimap_ (S arr ((a -> b) :+ arr')) a b where
  multimap_ (S _ (f :+ _)) = f

instance Multimap_ (S arr arr') x y => Multimap_ (S arr ((a -> b) :+ arr')) x y where
  multimap_ (S f (_ :+ g')) = multimap_ (S f g')

-- "id" instance
instance {-# INCOHERENT #-} Multimap_ (S arr ()) x x where
  multimap_ _ = id

-- "Functor" instance
instance {-# INCOHERENT #-} (Functor f, Multimap arr x y)
  => Multimap_ (S arr ()) (f x) (f y) where
  multimap_ (S f ()) = fmap (multimap f)

-- Intersection of "id" and "Functor" instances. Prefer "id".
-- When both of those instances match then this one should match and avoid an
-- unnecessary and overly restrictive Functor constraint.
instance {-# INCOHERENT #-} Multimap_ (S arr ()) (f x) (f x) where
  multimap_ _ = id

instance (Multimap arr y1 x1, Multimap arr x2 y2)
  => Multimap_ (S arr ()) (x1 -> x2) (y1 -> y2) where
  multimap_ (S f ()) u = multimap f . u . multimap f

-- "Bifunctor" instance.
instance {-# INCOHERENT #-} (Bifunctor f, Multimap arr x1 y1, Multimap arr x2 y2)
  => Multimap_ (S arr ()) (f x1 x2) (f y1 y2) where
  multimap_ (S f ()) = bimap (multimap f) (multimap f)

-- Intersection of "Bifunctor" and "Functor" instances. Prefer "Functor".
instance {-# INCOHERENT #-} (Functor (f x), Multimap arr x2 y2)
  => Multimap_ (S arr ()) (f x x2) (f x y2) where
  multimap_ (S f ()) = fmap (multimap f)

-- Intersection of "Bifunctor", "Functor", and "id" instances. Prefer "id".
instance {-# INCOHERENT #-} Multimap_ (S arr ()) (f x y) (f x y) where
  multimap_ _ = id