{-# LANGUAGE CPP               #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE EmptyCase         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE KindSignatures    #-}
{-# LANGUAGE Rank2Types        #-}
{-# LANGUAGE TypeOperators     #-}

-- | Functor of Functors
module Data.FFunctor where

#ifdef HAVE_TRANSFORMERS
import           Control.Monad.Trans.Class (MonadTrans, lift)
#endif
import           Control.Monad.IO.Class    (MonadIO, liftIO)
import           Data.Coerce
import           Data.Functor.Compose
import           Data.Functor.Const
import           Data.Functor.Product
import           Data.Functor.Sum
import qualified GHC.Generics              as Generics

-- | A Functor over Functors (aka Higher Kinded Functor)
class FFunctor (f :: (* -> *) -> *) where
  -- | Applies a natural transformation to a higher kinded type
  ffmap :: (Functor m, Functor n) => (forall a . (m a -> n a)) -> f m -> f n

  default ffmap :: (Generics.Generic1 f, FFunctor (Generics.Rep1 f), Functor m, Functor n) => (forall a . (m a -> n a)) -> f m -> f n
  ffmap f = Generics.to1 . ffmap f . Generics.from1
  {-# INLINE ffmap #-}

-- | Lifts an IO implementation of a higher kinded type (e.g. record of functions) into a MonadIO
--
--   e.g. `luftIO logger` lifts a `Logger IO` into a `Logger m`
luftIO :: FFunctor f => MonadIO m => f IO -> f m
luftIO = ffmap liftIO

#ifdef HAVE_TRANSFORMERS
-- | Lifts a higher kinded type (e.g. record of functions) into a monad transformer.
--
--   e.g. `luft logger` lifts a `Logger m` into a `Logger (ReaderT m Foo)`
luft :: FFunctor f => Monad m => MonadTrans t => Functor (t m) => f m -> f (t m)
luft = ffmap lift
#endif

instance FFunctor Generics.V1 where
  ffmap _ x = case x of {}
  {-# INLINE ffmap #-}

instance FFunctor Generics.U1 where
  ffmap _ = coerce
  {-# INLINE ffmap #-}

instance FFunctor f => FFunctor (Generics.Rec1 f) where
  ffmap f (Generics.Rec1 a) = Generics.Rec1 (ffmap f a)
  {-# INLINE ffmap #-}

instance FFunctor (Generics.K1 i c) where
  ffmap _ = coerce
  {-# INLINE ffmap #-}

instance FFunctor f => FFunctor (Generics.M1 i c f) where
  ffmap f (Generics.M1 a) = Generics.M1 (ffmap f a)
  {-# INLINE ffmap #-}

instance (FFunctor f, FFunctor g) => FFunctor ((Generics.:+:) f g) where
  ffmap f (Generics.L1 a) = Generics.L1 (ffmap f a)
  ffmap f (Generics.R1 a) = Generics.R1 (ffmap f a)
  {-# INLINE ffmap #-}

instance (FFunctor f, FFunctor g) => FFunctor ((Generics.:*:) f g) where
  ffmap f (a Generics.:*: b) = ffmap f a Generics.:*: ffmap f b
  {-# INLINE ffmap #-}

-- (f :.: g) a = f (g a), f must be (regular) Functor
instance (Functor f, FFunctor g) => FFunctor ((Generics.:.:) f g) where
  ffmap f (Generics.Comp1 a) = Generics.Comp1 (fmap (ffmap f) a)
  {-# INLINE ffmap #-}

instance (FFunctor f, FFunctor g) => FFunctor (Sum f g) where
  ffmap f (InL a) = InL (ffmap f a)
  ffmap f (InR a) = InR (ffmap f a)
  {-# INLINE ffmap #-}

instance (FFunctor f, FFunctor g) => FFunctor (Product f g) where
  ffmap f (Pair a b) = Pair (ffmap f a) (ffmap f b)
  {-# INLINE ffmap #-}

instance FFunctor (Const c) where
  ffmap _ = coerce
  {-# INLINE ffmap #-}

-- Compose f g a = f (g a), f must be (regular) Functor
instance (Functor f, FFunctor g) => FFunctor (Compose f g) where
  ffmap f (Compose a) = Compose (fmap (ffmap f) a)
  {-# INLINE ffmap #-}