{-# LANGUAGE
    RankNTypes
  , GeneralizedNewtypeDeriving
  #-}

module Control.Monad.Trans.Schedule.ExampleMFunctor (
    Ctx(..)
  , F
  , hoist'
  ) where

import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Control.Monad.Morph

import Control.Monad.Trans.Schedule -- for haddock

{-| A simpler version of 'ScheduleT' that has the "same shape" in a way that is
relevant to what we're trying to accomplish, which is to define 'hoist' for it.

It is effecively a 'StateT' whose state type is the same as[*] the monad type
that it's transforming.

- [*] or more generally, a (covariant) functor of - e.g. see 'F'.
-}
newtype Ctx m a = Ctx { getC :: StateT (F m) m a }
  deriving (Functor, Applicative, Monad)

-- | A type that represents the state type, that is dependent on @m@. This could
-- be any covariant functor of @m@ and everything we say in the rest of this file
-- would still be true.
type F m = m ()

instance MonadTrans Ctx where
  lift = Ctx . lift

-- | This is based on 'hoist'' which is 'undefined'.
instance MFunctor Ctx where
  hoist morph = Ctx . StateT . hoist' morph . runStateT . getC

{-| To 'hoist' something, we apply a morphism @m -> n@ to the inner monad @m@.
This is usually not so hard. But with 'Ctx', @m@ also determines the state type
(roughly @m -> m@) so we must also transform that. In other words we need to
somehow transform @m -> m@ to @n -> n@, using only a morphism @m -> n@. This is
probably impossible:

@(->)@ is a 'Data.Profunctor' - a functor of two arguments, contravariant in
the first and covariant in the second:

> dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

To transform @p m m@ into @p n n@, we need both @m -> n@ and @n -> m@:

> dimap :: (n -> m) -> (m -> n) -> p m m -> p n n -- substitute vars

An alternative is to try to treat @m -> m@ as a functor (of one argument) which
is both covariant and contravariant in that argument. But it is a known result
that this would be useless, see 'Data.Functor.Contravariant.phantom'.

If this was too abstract, you can look at the source code of our attempt to
actually implement 'hoist''.

-}

hoist' :: Monad m
  => (forall a. m a -> n a)
  -> (F m -> m (b, F m))
  -> (F n -> n (b, F n))
hoist' morph s0 s = morph $ do
    let s' = morph `contramorph` s
    (a, t') <- s0 s'
    let t = morph `fmorph` t'
    return (a, t)

contramorph :: (forall a. m a -> n a) -> F n -> F m
contramorph _ _ = undefined -- can't do it :(

fmorph :: (forall a. m a -> n a) -> F m -> F n
fmorph m s = m s