{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds    #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Barbies.Internal.FunctorT
  ( FunctorT(..)
  , gtmapDefault
  , CanDeriveFunctorT
  )

where

import Barbies.Generics.Functor (GFunctor(..))

import Control.Applicative.Backwards(Backwards (..))
import Control.Applicative.Lift(Lift, mapLift )

#if MIN_VERSION_transformers(0,5,3)
import Control.Monad.Trans.Accum(AccumT, mapAccumT)
#endif
import Control.Monad.Trans.Except(ExceptT, mapExceptT)
import Control.Monad.Trans.Identity(IdentityT, mapIdentityT)
import Control.Monad.Trans.Maybe(MaybeT, mapMaybeT)
import Control.Monad.Trans.RWS.Lazy as Lazy (RWST, mapRWST)
import Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
import Control.Monad.Trans.Reader(ReaderT, mapReaderT)
import Control.Monad.Trans.State.Lazy as Lazy (StateT, mapStateT)
import Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT)
import Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)

import Data.Functor.Compose   (Compose (..))
import Data.Functor.Product   (Product (..))
import Data.Functor.Reverse   (Reverse (..))
import Data.Functor.Sum       (Sum (..))
import Data.Generics.GenericN
import Data.Proxy             (Proxy (..))
import Data.Kind              (Type)

-- | Functor from indexed-types to indexed-types. Instances of 'FunctorT' should
--   satisfy the following laws:
--
-- @
-- 'tmap' 'id' = 'id'
-- 'tmap' f . 'tmap' g = 'tmap' (f . g)
-- @
--
-- There is a default 'tmap' implementation for 'Generic' types, so
-- instances can derived automatically.
class FunctorT (t :: (k -> Type) -> k' -> Type) where
  tmap :: (forall a . f a -> g a) -> t f x -> t g x

  default tmap
    :: forall f g x
    .  CanDeriveFunctorT t f g x
    => (forall a . f a -> g a)
    -> t f x
    -> t g x
  tmap = forall {k} {k} (t :: (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *) (x :: k).
CanDeriveFunctorT t f g x =>
(forall (a :: k). f a -> g a) -> t f x -> t g x
gtmapDefault

-- | @'CanDeriveFunctorT' T f g x@ is in practice a predicate about @T@ only.
--   Intuitively, it says that the following holds, for any arbitrary @f@:
--
--     * There is an instance of @'Generic' (T f)@.
--
--     * @T f x@ can contain fields of type @t f y@ as long as there exists a
--       @'FunctorT' t@ instance. In particular, recursive usages of @T f y@
--       are allowed.
--
--     * @T f x@ can also contain usages of @t f y@ under a @'Functor' h@.
--       For example, one could use @'Maybe' (T f y)@ when defining @T f y@.
type CanDeriveFunctorT t f g x
  = ( GenericP 1 (t f x)
    , GenericP 1 (t g x)
    , GFunctor 1 f g (RepP 1 (t f x)) (RepP 1 (t g x))
    )

-- | Default implementation of 'tmap' based on 'Generic'.
gtmapDefault
  :: CanDeriveFunctorT t f g x
  => (forall a . f a -> g a)
  -> t f x
  -> t g x
gtmapDefault :: forall {k} {k} (t :: (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *) (x :: k).
CanDeriveFunctorT t f g x =>
(forall (a :: k). f a -> g a) -> t f x -> t g x
gtmapDefault forall (a :: k). f a -> g a
f
  = forall (n :: Nat) a x. GenericP n a => Proxy n -> RepP n a x -> a
toP (forall {k} (t :: k). Proxy t
Proxy @1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (n :: Nat) (f :: k -> *) (g :: k -> *)
       (repbf :: k -> *) (repbg :: k -> *) (x :: k).
GFunctor n f g repbf repbg =>
Proxy n -> (forall (a :: k). f a -> g a) -> repbf x -> repbg x
gmap (forall {k} (t :: k). Proxy t
Proxy @1) forall (a :: k). f a -> g a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) a x. GenericP n a => Proxy n -> a -> RepP n a x
fromP (forall {k} (t :: k). Proxy t
Proxy @1)
{-# INLINE gtmapDefault #-}

-- ------------------------------------------------------------
-- Generic derivation: Special cases for FunctorT
-- -----------------------------------------------------------

type P = Param

instance
  ( FunctorT t
  ) => GFunctor 1 f g (Rec (t (P 1 f) x) (t f x))
                      (Rec (t (P 1 g) x) (t g x))
  where
  gmap :: forall (x :: k).
Proxy 1
-> (forall (a :: k). f a -> g a)
-> Rec (t (P 1 f) x) (t f x) x
-> Rec (t (P 1 g) x) (t g x) x
gmap Proxy 1
_ forall (a :: k). f a -> g a
h (Rec (K1 t f x
tf)) = forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec (forall k i c (p :: k). c -> K1 i c p
K1 (forall k k' (t :: (k -> *) -> k' -> *) (f :: k -> *) (g :: k -> *)
       (x :: k').
FunctorT t =>
(forall (a :: k). f a -> g a) -> t f x -> t g x
tmap forall (a :: k). f a -> g a
h t f x
tf))
  {-# INLINE gmap #-}


instance
  ( Functor h
  , FunctorT t
  ) => GFunctor 1 f g (Rec (h (t (P 1 f) x)) (h (t f x)))
                      (Rec (h (t (P 1 g) x)) (h (t g x)))
  where
  gmap :: forall (x :: k).
Proxy 1
-> (forall (a :: k). f a -> g a)
-> Rec (h (t (P 1 f) x)) (h (t f x)) x
-> Rec (h (t (P 1 g) x)) (h (t g x)) x
gmap Proxy 1
_ forall (a :: k). f a -> g a
h (Rec (K1 h (t f x)
htf)) = forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec (forall k i c (p :: k). c -> K1 i c p
K1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k k' (t :: (k -> *) -> k' -> *) (f :: k -> *) (g :: k -> *)
       (x :: k').
FunctorT t =>
(forall (a :: k). f a -> g a) -> t f x -> t g x
tmap forall (a :: k). f a -> g a
h) h (t f x)
htf))
  {-# INLINE gmap #-}


-- This is the same as the previous instance, but for nested (normal-flavoured)
-- functors.
instance
  ( Functor h
  , Functor m
  , FunctorT t
  ) => GFunctor 1 f g (Rec (m (h (t (P 1 f) x))) (m (h (t f x))))
                      (Rec (m (h (t (P 1 g) x))) (m (h (t g x))))
  where
  gmap :: forall (x :: k).
Proxy 1
-> (forall (a :: k). f a -> g a)
-> Rec (m (h (t (P 1 f) x))) (m (h (t f x))) x
-> Rec (m (h (t (P 1 g) x))) (m (h (t g x))) x
gmap Proxy 1
_ forall (a :: k). f a -> g a
h (Rec (K1 m (h (t f x))
mhtf)) = forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec (forall k i c (p :: k). c -> K1 i c p
K1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k k' (t :: (k -> *) -> k' -> *) (f :: k -> *) (g :: k -> *)
       (x :: k').
FunctorT t =>
(forall (a :: k). f a -> g a) -> t f x -> t g x
tmap forall (a :: k). f a -> g a
h)) m (h (t f x))
mhtf))
  {-# INLINE gmap #-}

-- --------------------------------
-- Instances for base types
-- --------------------------------

instance Functor f => FunctorT (Compose f) where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> Compose f f x -> Compose f g x
tmap forall (a :: k'). f a -> g a
h (Compose f (f x)
fga)
    = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: k'). f a -> g a
h f (f x)
fga)
  {-# INLINE tmap #-}

instance FunctorT (Product f) where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> Product f f x -> Product f g x
tmap forall (a :: k'). f a -> g a
h (Pair f x
fa f x
ga) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f x
fa (forall (a :: k'). f a -> g a
h f x
ga)
  {-# INLINE tmap #-}

instance FunctorT (Sum f) where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> Sum f f x -> Sum f g x
tmap forall (a :: k'). f a -> g a
h = \case
    InL f x
fa -> forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL f x
fa
    InR f x
ga -> forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR (forall (a :: k'). f a -> g a
h f x
ga)
  {-# INLINE tmap #-}

-- --------------------------------
-- Instances for transformers types
-- --------------------------------

#if MIN_VERSION_transformers(0,5,3)
instance FunctorT (AccumT w) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> AccumT w f x -> AccumT w g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a w (n :: * -> *) b.
(m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b
mapAccumT forall a. f a -> g a
h
  {-# INLINE tmap #-}
#endif

instance FunctorT Backwards where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> Backwards f x -> Backwards g x
tmap forall (a :: k'). f a -> g a
h (Backwards f x
fa)
    = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (forall (a :: k'). f a -> g a
h f x
fa)
  {-# INLINE tmap #-}

instance FunctorT Reverse where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> Reverse f x -> Reverse g x
tmap forall (a :: k'). f a -> g a
h (Reverse f x
fa) = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse (forall (a :: k'). f a -> g a
h f x
fa)
  {-# INLINE tmap #-}

instance FunctorT Lift where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> Lift f x -> Lift g x
tmap forall a. f a -> g a
h = forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> Lift f a -> Lift g a
mapLift forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (ExceptT e) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> ExceptT e f x -> ExceptT e g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT IdentityT where
  tmap :: forall (f :: k' -> *) (g :: k' -> *) (x :: k').
(forall (a :: k'). f a -> g a) -> IdentityT f x -> IdentityT g x
tmap forall (a :: k'). f a -> g a
h = forall {k1} {k2} (m :: k1 -> *) (a :: k1) (n :: k2 -> *) (b :: k2).
(m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT forall (a :: k'). f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT MaybeT where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> MaybeT f x -> MaybeT g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Lazy.RWST r w s) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> RWST r w s f x -> RWST r w s g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Lazy.mapRWST forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Strict.RWST r w s) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> RWST r w s f x -> RWST r w s g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (ReaderT r) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> ReaderT r f x -> ReaderT r g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Lazy.StateT s) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> StateT s f x -> StateT s g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Lazy.mapStateT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Strict.StateT s) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> StateT s f x -> StateT s g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Lazy.WriterT w) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> WriterT w f x -> WriterT w g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Lazy.mapWriterT forall a. f a -> g a
h
  {-# INLINE tmap #-}

instance FunctorT (Strict.WriterT w) where
  tmap :: forall (f :: * -> *) (g :: * -> *) x.
(forall a. f a -> g a) -> WriterT w f x -> WriterT w g x
tmap forall a. f a -> g a
h = forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT forall a. f a -> g a
h
  {-# INLINE tmap #-}