{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeOperators #-}
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
class FFunctor (f :: (* -> *) -> *) where
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 #-}
luftIO :: FFunctor f => MonadIO m => f IO -> f m
luftIO = ffmap liftIO
#ifdef HAVE_TRANSFORMERS
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 #-}
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 #-}
instance (Functor f, FFunctor g) => FFunctor (Compose f g) where
ffmap f (Compose a) = Compose (fmap (ffmap f) a)
{-# INLINE ffmap #-}