{-# LANGUAGE Safe #-}

-- | This should probably be a separate library, but it provides a number of
--   functor type classes between various categories.
module Yaya.Functor
  ( DFunctor (dmap),
    HFunctor (hmap),
    firstMap,
  )
where

import "base" Control.Category (Category ((.)))
import "base" Data.Bifunctor (Bifunctor, first)
import "base" Data.Function (($))
import "base" Data.Functor (Functor (fmap))
import "base" Data.Functor.Compose (Compose (Compose))
import "base" Data.Functor.Product (Product (Pair))
import "base" Data.Kind (Type)
import "transformers" Control.Applicative.Backwards (Backwards (Backwards))
import "transformers" Control.Applicative.Lift (Lift (Other, Pure))
import qualified "transformers" Control.Monad.Trans.Except as Ex
import qualified "transformers" Control.Monad.Trans.Identity as I
import qualified "transformers" Control.Monad.Trans.Maybe as M
import qualified "transformers" Control.Monad.Trans.RWS.Lazy as RWS
import qualified "transformers" Control.Monad.Trans.RWS.Strict as RWS'
import qualified "transformers" Control.Monad.Trans.Reader as R
import qualified "transformers" Control.Monad.Trans.State.Lazy as S
import qualified "transformers" Control.Monad.Trans.State.Strict as S'
import qualified "transformers" Control.Monad.Trans.Writer.Lazy as W'
import qualified "transformers" Control.Monad.Trans.Writer.Strict as W

-- | A functor from the category of endofunctors to *Hask*. The @D@ is meant to
--   be a mnemonic for “down”, as we’re “lowering” from endofunctors to types.
class DFunctor (d :: (Type -> Type) -> Type) where
  dmap :: (forall x. f x -> g x) -> d f -> d g

-- | This isn’t a Functor instance because of the position of the @a@, but you
--   can use it like:
--   > newtype List a = List (Mu (XNor a))
--   > instance Functor List where
--   >   fmap f (List mu) = List (firstMap f mu)
firstMap :: (DFunctor d, Bifunctor f) => (a -> b) -> d (f a) -> d (f b)
firstMap :: forall (d :: (* -> *) -> *) (f :: * -> * -> *) a b.
(DFunctor d, Bifunctor f) =>
(a -> b) -> d (f a) -> d (f b)
firstMap a -> b
f = (forall x. f a x -> f b x) -> d (f a) -> d (f b)
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> d f -> d g
forall (d :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
DFunctor d =>
(forall x. f x -> g x) -> d f -> d g
dmap ((a -> b) -> f a x -> f b x
forall a b c. (a -> b) -> f a c -> f b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)

-- | An endofunctor in the category of endofunctors.
--
--  __NB__: This is similar to `Control.Monad.Morph.MFunctor` /
--         `Control.Monad.Morph.hoist` from mmorph, but without the
--         `Control.Monad.Monad` constraint on @f@.
class HFunctor (h :: (Type -> Type) -> Type -> Type) where
  hmap :: (forall x. f x -> g x) -> h f a -> h g a

instance HFunctor (Ex.ExceptT e) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ExceptT e f a -> ExceptT e g a
hmap forall x. f x -> g x
nat ExceptT e f a
m = g (Either e a) -> ExceptT e g a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Ex.ExceptT (f (Either e a) -> g (Either e a)
forall x. f x -> g x
nat (ExceptT e f a -> f (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Ex.runExceptT ExceptT e f a
m))

instance HFunctor I.IdentityT where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> IdentityT f a -> IdentityT g a
hmap forall x. f x -> g x
nat IdentityT f a
m = g a -> IdentityT g a
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
I.IdentityT (f a -> g a
forall x. f x -> g x
nat (IdentityT f a -> f a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
I.runIdentityT IdentityT f a
m))

instance HFunctor M.MaybeT where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> MaybeT f a -> MaybeT g a
hmap forall x. f x -> g x
nat MaybeT f a
m = g (Maybe a) -> MaybeT g a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
M.MaybeT (f (Maybe a) -> g (Maybe a)
forall x. f x -> g x
nat (MaybeT f a -> f (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
M.runMaybeT MaybeT f a
m))

instance HFunctor (R.ReaderT r) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> ReaderT r f a -> ReaderT r g a
hmap forall x. f x -> g x
nat ReaderT r f a
m = (r -> g a) -> ReaderT r g a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
R.ReaderT ((r -> g a) -> ReaderT r g a) -> (r -> g a) -> ReaderT r g a
forall a b. (a -> b) -> a -> b
$ f a -> g a
forall x. f x -> g x
nat (f a -> g a) -> (r -> f a) -> r -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ReaderT r f a -> r -> f a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT ReaderT r f a
m

instance HFunctor (RWS.RWST r w s) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> RWST r w s f a -> RWST r w s g a
hmap forall x. f x -> g x
nat RWST r w s f a
m = (r -> s -> g (a, s, w)) -> RWST r w s g a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.RWST (\r
r s
s -> f (a, s, w) -> g (a, s, w)
forall x. f x -> g x
nat (RWST r w s f a -> r -> s -> f (a, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.runRWST RWST r w s f a
m r
r s
s))

instance HFunctor (RWS'.RWST r w s) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> RWST r w s f a -> RWST r w s g a
hmap forall x. f x -> g x
nat RWST r w s f a
m = (r -> s -> g (a, s, w)) -> RWST r w s g a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS'.RWST (\r
r s
s -> f (a, s, w) -> g (a, s, w)
forall x. f x -> g x
nat (RWST r w s f a -> r -> s -> f (a, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS'.runRWST RWST r w s f a
m r
r s
s))

instance HFunctor (S.StateT s) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> StateT s f a -> StateT s g a
hmap forall x. f x -> g x
nat StateT s f a
m = (s -> g (a, s)) -> StateT s g a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S.StateT ((s -> g (a, s)) -> StateT s g a)
-> (s -> g (a, s)) -> StateT s g a
forall a b. (a -> b) -> a -> b
$ f (a, s) -> g (a, s)
forall x. f x -> g x
nat (f (a, s) -> g (a, s)) -> (s -> f (a, s)) -> s -> g (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StateT s f a -> s -> f (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT StateT s f a
m

instance HFunctor (S'.StateT s) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> StateT s f a -> StateT s g a
hmap forall x. f x -> g x
nat StateT s f a
m = (s -> g (a, s)) -> StateT s g a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S'.StateT ((s -> g (a, s)) -> StateT s g a)
-> (s -> g (a, s)) -> StateT s g a
forall a b. (a -> b) -> a -> b
$ f (a, s) -> g (a, s)
forall x. f x -> g x
nat (f (a, s) -> g (a, s)) -> (s -> f (a, s)) -> s -> g (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StateT s f a -> s -> f (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S'.runStateT StateT s f a
m

instance HFunctor (W.WriterT w) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> WriterT w f a -> WriterT w g a
hmap forall x. f x -> g x
nat WriterT w f a
m = g (a, w) -> WriterT w g a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W.WriterT (f (a, w) -> g (a, w)
forall x. f x -> g x
nat (WriterT w f a -> f (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W.runWriterT WriterT w f a
m))

instance HFunctor (W'.WriterT w) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> WriterT w f a -> WriterT w g a
hmap forall x. f x -> g x
nat WriterT w f a
m = g (a, w) -> WriterT w g a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W'.WriterT (f (a, w) -> g (a, w)
forall x. f x -> g x
nat (WriterT w f a -> f (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
W'.runWriterT WriterT w f a
m))

instance (Functor f) => HFunctor (Compose f) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Compose f f a -> Compose f g a
hmap forall x. f x -> g x
nat (Compose f (f a)
f) = f (g a) -> Compose f g a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((f a -> g a) -> f (f a) -> f (g a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> g a
forall x. f x -> g x
nat f (f a)
f)

instance HFunctor (Product f) where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Product f f a -> Product f g a
hmap forall x. f x -> g x
nat (Pair f a
f f a
g) = f a -> g a -> Product f g a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
f (f a -> g a
forall x. f x -> g x
nat f a
g)

instance HFunctor Backwards where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Backwards f a -> Backwards g a
hmap forall x. f x -> g x
nat (Backwards f a
f) = g a -> Backwards g a
forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (f a -> g a
forall x. f x -> g x
nat f a
f)

instance HFunctor Lift where
  hmap :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Lift f a -> Lift g a
hmap forall x. f x -> g x
_ (Pure a
a) = a -> Lift g a
forall (f :: * -> *) a. a -> Lift f a
Pure a
a
  hmap forall x. f x -> g x
nat (Other f a
f) = g a -> Lift g a
forall (f :: * -> *) a. f a -> Lift f a
Other (f a -> g a
forall x. f x -> g x
nat f a
f)