{-# LANGUAGE
  EmptyCase,
  FlexibleContexts,
  FlexibleInstances,
  MultiParamTypeClasses,
  QuantifiedConstraints,
  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

-- | Generic implementation of 'fmap'. See also 'DeriveFunctor' for deriving-via,
-- 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 = to . gmap1 f . from :: GFunctorRep a b f => f a -> f b

-- | 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 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'.)
--
-- '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 = solomap_

-- ** Constraints for @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

-- ** Constraint for @gsolomap@

-- | 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@

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

-- * Deriving Via

-- | @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:
--
-- @
-- {-\# 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 = coerce' (gfmap @f) where
    coerce' :: Coercible s t => (r -> s) -> (r -> t)
    coerce' = coerce

--

class GMap1 a b f g where
  gmap1 :: (a -> b) -> f () -> g ()

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

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

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

instance GMap1 a b U1 U1 where
  gmap1 _ U1 = U1

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

instance Solomap_ a b x y => GMap1 a b (K1 i x) (K1 i' y) where
  gmap1 = coerce (solomap_ @a @b @x @y)

-- | Internal implementation of 'Solomap'.
class Solomap_ a b x y where
  solomap_ :: (a -> b) -> x -> y

instance {-# INCOHERENT #-} Solomap_ a b a b where
  solomap_ = id

-- "id" instance
instance {-# INCOHERENT #-} Solomap_ a b x x where
  solomap_ _ = id

-- "Functor" instance
instance {-# INCOHERENT #-} (Functor f, Solomap_ a b x y) => Solomap_ a b (f x) (f y) where
  solomap_ = fmap . solomap_

-- 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 #-} Solomap_ a b (f x) (f x) where
  solomap_ _ = id

instance (Solomap_ a b y1 x1, Solomap_ a b x2 y2) => Solomap_ a b (x1 -> x2) (y1 -> y2) where
  solomap_ f u = solomap_ f . u . solomap_ f

-- "Bifunctor" instance.
instance {-# INCOHERENT #-} (Bifunctor f, Solomap_ a b x1 y1, Solomap_ a b x2 y2)
  => Solomap_ a b (f x1 x2) (f y1 y2) where
  solomap_ f = bimap (solomap_ f) (solomap_ f)

-- Intersection of "Bifunctor" and "Functor" instances. Prefer "Functor".
instance {-# INCOHERENT #-} (Functor (f x), Solomap_ a b x2 y2)
  => Solomap_ a b (f x x2) (f x y2) where
  solomap_ = fmap . solomap_

-- Intersection of "Bifunctor", "Functor", and "id" instances. Prefer "id".
instance {-# INCOHERENT #-} Solomap_ a b (f x y) (f x y) where
  solomap_ _ = id