newtype TU t u a = TU (t :. u := a)
newtype UT t u a = UT (u :. t := a)

type instance Schema (Reader e) = TU ((->) e)
type instance Schema (Either e) = UT (Either e)
type instance Schema Maybe = UT Maybe

(<$$>) :: (Functor t, Functor u) => (a -> b) -> t :. u := a -> t :. u := b
(<$$>) = (<$>) . (<$>)
(<**>) :: (Applicative t, Applicative u) => t :. u := (a -> b) -> t :. u := a -> t :. u := b
f <**> x = (<*>) <$> f <*> x
instance (Functor t, Functor u) => Functor (TU t u) where
    fmap f (TU x) = TU $ f <$$> x
instance (Applicative t, Applicative u) => Applicative (TU t u) where
    pure = TU . pure . pure
    TU f <*> TU x = TU $ f <**> x
instance (Functor t, Functor u) => Functor (UT t u) where
    fmap f (UT x) = UT $ f <$$> x
instance (Applicative t, Applicative u) => Applicative (UT t u) where
    pure = UT . pure . pure
    UT f <*> UT x = UT $ f <**> x

instance (Monad t, Monad u) => Monad (TU t u) where
  x >>= f = ???
instance (Monad t, Monad u) => Monad (UT t u) where
  x >>= f = ???

instance Monad u => Monad (TU ((->) e) u) where
    TU x >>= f = TU $ \e -> x e >>= ($ e) . run . f
instance Monad u => Monad (UT (Either e) u) where
    UT x >>= f = UT $ x >>= \case
        Left e -> pure $ Left e
        Right r -> run $ f r
instance Monad u => Monad (UT Maybe u) where
    UT x >>= f = UT $ x >>= \case
        Nothing -> pure Nothing
        Just r -> run $ f r

class (Functor t, Foldable t) => Traversable t where
    traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
instance Traversable Maybe where
    traverse _ Nothing = pure Nothing
    traverse f (Just x) = Just <$> f x
instance Traversable (Either a) where
    traverse _ (Left x) = pure (Left x)
    traverse f (Right y) = Right <$> f y

instance (Traversable t, Monad t, Monad u) => Monad (UT t u) where
    UT x >>= f = UT $ x >>= \i -> join <$> traverse (run . f) i

class Functor g => Distributive g where
    collect :: Functor f => (a -> g b) -> f a -> g (f b)
instance Distributive ((->) e) where
    collect f q e = flip f e <$> q

sequence :: (Traversable t, Applicative u) => t (u a) -> u (t a)
sequence = traverse id
distribute :: (Distributive t, Functor u) => u (t a) -> t (u a)
distribute = collect id

instance (Monad t, Distributive t, Monad u) => Monad (TU t u) where
    TU x >>= f = TU $ x >>= \i -> join <$> collect (run . f) i

newtype TUT t t' u a = TUT (t :. u :. t' := a)
newtype State s a = State ((->) s :. (,) s := a)
newtype Store s a = Store ((,) s :. (->) s := a)
type instance Schema (State s) = TUT ((->) s) ((,) s)
type instance Schema (Store s) = TUT ((,) s) ((->) s)

instance (Functor t, Functor t', Functor u) => Functor (TUT t t' u) where
    fmap f (TUT x) = TUT $ f <$$$> x

class Functor t => Adjunction t u where
    leftAdjunct  :: (t a -> b) -> a -> u b
    rightAdjunct :: (a -> u b) -> t a -> b
    unit :: a -> u :. t := a
    unit = leftAdjunct id
    counit :: t :. u := a -> a
    counit = rightAdjunct id
instance Adjunction ((,) s) ((->) s) where
    leftAdjunct :: ((s, a) -> b) -> a -> (s -> b)
    leftAdjunct f a s = f (s, a)
    rightAdjunct :: (a -> s -> b) -> (s, a) -> b
    rightAdjunct f (s, a) = f a s
    unit :: a -> s -> (s, a)
    unit x = \s -> (s, x)
    counit :: (s, (s -> a)) -> a
    counit (s, f) = f s

instance Monad (State s) where
    State x >>= f = State $ rightAdjunct (run . f) <$> x
    -- Или так: State x >>= f = State $ counit <$> ((run . f) <$$> x)
    return = State . unit

instance (Adjunction t' t, Monad u) => Monad (TUT t t' u) where
    x >>= f = TUT $ (>>= rightAdjunct (run . f)) <$> run x
    return = TUT . (leftAdjunct pure)

instance (Adjunction t' t, Comonad u) => Comonad (TUT t' t := u) where
    extend f x = TUT $ (=>> leftAdjunct (f . TUT)) <$> run x
    extract = rightAdjunct extract . run

instance (Adjunction t' t, Distributive t) => MonadTrans (TUT t t') where
    lift = TUT . collect (leftAdjunct id)
instance (Adjunction t' t, Applicative t, forall u . Traversable u) => ComonadTrans (TUT t' t) where
    lower = rightAdjunct (traverse id) . run