Generic coyoneda

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Main
  ( main
  ) where

import Prelude hiding ((.), id)

import Control.Arrow (Kleisli (..))
import Control.Category (Category, (.), id)
import Data.Profunctor (Profunctor, rmap)

-- From Control.Categorical.Functor.
class (Category r, Category t) => GFunctor f r t | f r -> t, f t -> r where
  gfmap :: r a b -> t (f a) (f b)

--------------------------------------------------------------------------------

data Coyoneda p f a where
  Coyoneda :: p a b -> f a -> Coyoneda p f b

instance Profunctor p => Functor (Coyoneda p f) where
  fmap f (Coyoneda g a) = Coyoneda (rmap f g) a

instance Category p => GFunctor (Coyoneda p f) p (->) where
  gfmap f (Coyoneda g a) = Coyoneda (f . g) a

liftCoyoneda :: Category p => f a -> Coyoneda p f a
liftCoyoneda = Coyoneda id

lowerCoyoneda :: GFunctor f p (->) => Coyoneda p f a -> f a
lowerCoyoneda (Coyoneda f a) = gfmap f a

sequenceCoyoneda :: (Applicative m, Traversable f) => Coyoneda (Kleisli m) f a -> m (f a)
sequenceCoyoneda (Coyoneda f a) = traverse (runKleisli f) a

--------------------------------------------------------------------------------

prompt :: String -> IO String
prompt m = putStr m *> putStr "> " *> getLine

main :: IO ()
main = example1 *> example2

example1 :: IO ()
example1 =
  let foo = liftCoyoneda ["A"] in
  let bar = gfmap (Kleisli prompt) foo in
  let baz = gfmap (Kleisli prompt) bar in
  print =<< sequenceCoyoneda baz

example2 :: IO ()
example2 =
  let foo = ["A"] in
  let bar = traverse prompt foo in
  let baz = traverse prompt =<< bar in
  print =<< baz