Double continuations?

DoubleCont.hs

{-# LANGUAGE ApplicativeDo #-} 
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-} 

import Control.Applicative (WrappedMonad(..))
import Data.Profunctor
import Data.Functor.Apply
import Data.Functor.Bind

newtype Circa f g a b i o =
  Circa { runCirca :: (f b -> a) -> (g o -> b) -> (i -> g o) }

instance Functor g => Profunctor (Circa f g a b) where
  dimap l r c =
    Circa $ \g h x ->
      fmap r (runCirca c g (h . fmap r) (l x))

instance Functor g => Functor (Circa f g a b i) where fmap = rmap

instance Applicative g => Applicative (Circa f g a b i) where
  pure x =
    Circa $ \_ _ _ -> pure x

  lhs <*> rhs =
    Circa $ \g h x -> do
      f <- runCirca lhs g (\ff -> let fin fx = h (ff <*> fx) in
                                  fin (runCirca rhs g fin x)) x
      x <- runCirca rhs g (\fx -> let fin ff = h (ff <*> fx) in
                                  fin (runCirca lhs g fin x)) x
      pure (f x)

instance Monad g => Monad (Circa f g a b i) where
  c >>= f =
    Circa $ \g h x ->
      let runA fa = h $ do
            a <- fa
            runCirca (f a) g h x
          runB = (\b -> runCirca b g h x) . f
       in runCirca c g runA x >>= runB

-------------------------------------------------------------------------------
newtype Intra f g i o a b =
  Intra { runIntra :: (f b -> a) -> (g o -> a) -> (i -> g o) }

morphF :: (forall x. f x -> f' x) -> Intra f g i o a b -> Intra f' g i o a b
morphF f i =
  Intra $ \g ->
    runIntra i (g . f)

morphG :: (forall x. g x -> g' x) -> Intra f g i o a b -> Intra f g' i o a b
morphG f int =
  Intra $ \g h i ->
    f (runIntra int g (h . f) i)

morphFG :: (forall x. f x -> f' x) -> Intra f f i o a b -> Intra f' f' i o a b
morphFG f int = 
  Intra $ \g h i ->
    f (runIntra int (g . f) (h . f) i)

instance Functor f => Profunctor (Intra f g i o) where
  dimap l r i =
    Intra $ \g h x ->
      runIntra i (l . g . fmap r) (l . h) x

instance Functor f => Functor (Intra f g i o a) where fmap = rmap

instance Apply f => Apply (Intra f g i o a) where
  lhs <.> rhs =
    Intra $ \g h x ->
      let onLhs ff    = h (runIntra rhs (onRhs ff) h x)
          onRhs ff fa = g (ff <.> fa)
      in runIntra lhs onLhs h x

instance (Applicative f, Applicative g) => Applicative (Intra f g i a a) where
  pure x =
    Intra $ \g h _ ->
      pure (g (pure x))

  lhs <*> rhs =
    morphF unwrapApplicative $
      morphF WrapApplicative lhs <.> morphF WrapApplicative rhs

instance Bind f => Bind (Intra f f i o a) where
  intra >>- fn =
    Intra $ \g h i ->
      let inner fx = h $ fx >>- \x -> runIntra (fn x) g h i
       in runIntra intra inner h i

instance Monad f => Monad (Intra f f i a a) where
  intra >>= fn =
    morphFG unwrapMonad $
      morphFG WrapMonad intra >>- morphFG WrapMonad . fn