-- | This should probably be a separate library, but it provides a number of
--   functor type classes between various categories.
module Yaya.Functor where

import Control.Applicative.Backwards (Backwards (..))
import Control.Applicative.Lift (Lift (..))
import qualified Control.Monad.Trans.Except as Ex
import qualified Control.Monad.Trans.Identity as I
import qualified Control.Monad.Trans.Maybe as M
import qualified Control.Monad.Trans.RWS.Lazy as RWS
import qualified Control.Monad.Trans.RWS.Strict as RWS'
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State.Lazy as S
import qualified Control.Monad.Trans.State.Strict as S'
import qualified Control.Monad.Trans.Writer.Lazy as W'
import qualified Control.Monad.Trans.Writer.Strict as W
import Data.Bifunctor
import Data.Functor.Compose (Compose (..))
import Data.Functor.Product (Product (..))

-- | 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 :: (* -> *) -> *) 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 :: (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 (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 (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 `Monad`
--          constraint on `f`.
class HFunctor (h :: (* -> *) -> * -> *) where
  hmap :: (forall x. f x -> g x) -> h f a -> h g a

instance HFunctor (Ex.ExceptT e) where
  hmap :: (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 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 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 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
. 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 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 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 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
. 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 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
. 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 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 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 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 (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 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 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 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)