ForkChurch.hs

module Fork where

newtype Fork' f a = Fork' { runFork :: forall r. (a -> r) ->
                                       (f r -> r) ->
                                       (forall b. Fork' f b -> r -> r) -> r } deriving Functor

instance Applicative (Fork' f) where
  pure a = Fork' (\kh _ _ -> kh a)
  Fork' f <*> Fork' g = Fork' (\kh ka kf -> f (\a -> g (\b -> kh (a b)) ka kf) ka kf)


instance Monad (Fork' f) where
  return = pure
  Fork' m >>= f = Fork' (\kh ka kf -> m (\a -> runFork (f a) kh ka kf) ka kf)


liftF' :: Functor f => f a -> Fork' f a
liftF' f = Fork' (\kh ka _ -> ka (fmap kh f))


fork' :: Functor f => Fork' f a -> Fork' f ()
fork' f = Fork' (\kh _ kf -> kf f (kh ()))