Breadth-first traversal of a rose tree using a Scott encoding of the Phases applicative

HyperPhases.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -Wall -Werror -Wextra -Wno-name-shadowing #-}

module HyperPhases where

import Control.Applicative (liftA2)
import Data.Functor ((<&>))

newtype Phases f a = Phases
  { runPhases :: forall r. (f a -> r) -> (forall x. f (x -> a) -> Phases f x -> r) -> r
  }

phases :: (f a -> r) -> (forall x. f (x -> a) -> Phases f x -> r) -> Phases f a -> r
phases lift apply pa = runPhases pa lift apply

runPhasesForwards :: Applicative f => Phases f a -> f a
runPhasesForwards = phases id \mf px -> mf <*> runPhasesForwards px

now :: f a -> Phases f a
now ma = Phases \lift _ -> lift ma

push :: f (a -> b) -> Phases f a -> Phases f b
push mf pa = Phases \_ apply -> apply mf pa

instance Functor f => Functor (Phases f) where
  fmap f = phases (now . fmap f) (push . fmap (f .))

instance Applicative f => Applicative (Phases f) where
  pure = now . pure
  (<*>) = phases meld with
    where
      meld :: Applicative f => f (a -> b) -> Phases f a -> Phases f b
      meld mf = phases (now . (mf <*>)) (push . liftA2 (.) mf)

      with :: Applicative f => f (x -> a -> b) -> Phases f x -> Phases f a -> Phases f b
      with mg px = phases
        do \ma -> push (liftA2 flip mg ma) px
        do \mh -> push (liftA2 tup mg mh) . liftA2 ess px

      tup a b k = k a b
      ess x y g h = g x (h y)

data Tree a = a :> [Tree a]

bft :: Applicative f => (a -> f b) -> Tree a -> f (Tree b)
bft = \f -> runPhasesForwards . schedule f
  where
    schedule :: Applicative f => (a -> f b) -> Tree a -> Phases f (Tree b)
    schedule f (a :> ts) = push (f a <&> (:>)) (traverse (schedule f) ts)

-- |
-- >>> import Data.Functor.Const
-- >>> import Data.Monoid (Endo(..))
-- >>> getConst (bft (Const . Endo . (:)) exampleTree) `appEndo` []
-- [0,1,2,3,4,5,6,7]
exampleTree :: Tree Int
exampleTree =
  0
    :> [ 1
           :> [ 4 :> [],
                5 :> []
              ],
         2 :> [],
         3
           :> [ 6 :> [],
                7 :> []
              ]
       ]