## Implicit Corecursive Queues

# Fusion

I was looking again at one of my implementations of breadth-first traversals:

```
bfe :: Tree a -> [a]
= f r b []
bfe r where
Node x xs) fw bw = x : fw (xs : bw)
f (
= []
b [] = foldl (foldr f) b qs [] b qs
```

And I was wondering if I could *fuse* away the intermediate
list. On the following line:

`Node x xs) fw bw = x : fw (xs : bw) f (`

The `xs : bw`

is a little annoying, because we
*know* it’s going to be consumed eventually by a fold. When that
happens, it’s often a good idea to remove the list, and just inline the
fold. In other words, if you see the following:

`foldr f b (x : y : [])`

You should replace it with this:

` f x (f y b)`

If you try and do that with the above definition, you get something like the following:

```
bfenum :: Tree a -> [a]
= f t b b
bfenum t where
Node x xs) fw bw = x : fw (bw . flip (foldr f) xs)
f (= x b b x
```

# Infinite Types

The trouble is that the above comes with type errors:

`Cannot construct the infinite type: b ~ (b -> c) -> [a]`

This error shows up occasionally when you try and do heavy church-encoding in Haskell. You get a similar error when trying to encode the Y combinator:

`= \f -> (\x -> f (x x)) (\x -> f (x x)) y `

`• Occurs check: cannot construct the infinite type: t0 ~ t0 -> t`

The solution for the y combinator is to use a newtype, where we can catch the recursion at a certain point to help the typechecker.

```
newtype Mu a = Mu (Mu a -> a)
= (\h -> h $ Mu h) (\x -> f . (\(Mu g) -> g) x $ x) y f
```

The trick for our queue is similar:

```
newtype Q a = Q { q :: (Q a -> [a]) -> [a] }
bfenum :: Tree a -> [a]
= q (f t b) e
bfenum t where
Node x xs) fw = Q (\bw -> x : q fw (bw . flip (foldr f) xs))
f (= fix (Q . flip id)
b = fix (flip q) e
```

This is actually equivalent to the continuation monad:

```
newtype Fix f = Fix { unFix :: f (Fix f) }
type Q a = Fix (ContT a [])
= runContT . unFix
q
bfenum :: Tree a -> [a]
= q (f t b) e
bfenum t where
Node x xs) fw = Fix (mapContT (x:) (flip (foldr f) xs <$> unFix fw))
f (= fix (Fix . pure)
b = fix (flip q) e
```

# Terminating

There’s a problem though: this algorithm never checks for an end. That’s ok if there isn’t one, mind you. For instance, with the following “unfold” function:

```
infixr 9 #.
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
#.) _ = coerce
({-# INLINE (#.) #-}
bfUnfold :: (a -> (b,[a])) -> a -> [b]
= g t (fix (Q #. flip id)) (fix (flip q))
bfUnfold f t where
= x : q fw (bw . flip (foldr ((Q .) #. g)) xs)
g b fw bw where
= f b (x,xs)
```

We can write a decent enumeration of the rationals.

```
-- Stern-Brocot
rats1 :: [Rational]
= bfUnfold step ((0,1),(1,0))
rats1 where
= (n % d,[(lb , m),(m , rb)])
step (lb,rb) where
@(n,d) = adj lb rb
m= (w+y,x+z)
adj (w,x) (y,z)
-- Calkin-Wilf
rats2 :: [Rational]
= bfUnfold step (1,1)
rats2 where
= (m % n,[(m,m+n),(n+m,n)]) step (m,n)
```

However, if we *do* want to stop at some point, we need a
slight change to the queue type.

```
newtype Q a = Q { q :: Maybe (Q a -> [a]) -> [a] }
bfenum :: Tree a -> [a]
= q (f t b) e
bfenum t where
Node x xs) fw = Q (\bw -> x : q fw (Just (m bw . flip (foldr f) xs)))
f (= fix (Q . maybe [] . flip ($))
b = Nothing
e = fromMaybe (flip q e) m
```

# Monadic

We can actually add in a monad to the above unfold without much difficulty.

```
newtype Q m a = Q { q :: Maybe (Q m a -> m [a]) -> m [a] }
bfUnfold :: Monad m => (a -> m (b,[a])) -> a -> m [b]
= g t b e
bfUnfold f t where
= f s >>=
g s fw bw ~(x,xs) -> (x :) <$> q fw (Just (m bw . flip (foldr ((Q .) #. g)) xs))
\
= fix (Q #. maybe (pure []) . flip ($))
b = Nothing
e = fromMaybe (flip q e) m
```

And it passes the torture tests for a linear-time breadth-first unfold from Feuer (2015). It breaks when you try and use it to build a tree, though.

# Phases

Finally, we can try and make the above code a little more modular, by actually packaging up the queue type as a queue.

```
newtype Q a = Q { q :: Maybe (Q a -> [a]) -> [a] }
newtype Queue a = Queue { runQueue :: Q a -> Q a }
now :: a -> Queue a
= Queue (\fw -> Q (\bw -> x : q fw bw))
now x
delay :: Queue a -> Queue a
= Queue (\fw -> Q (\bw -> q fw (Just (m bw . runQueue xs))))
delay xs where
= fromMaybe (flip q Nothing)
m
instance Monoid (Queue a) where
mempty = Queue id
mappend (Queue xs) (Queue ys) = Queue (xs . ys)
run :: Queue a -> [a]
Queue xs) = q (xs b) Nothing
run (where
= fix (Q . maybe [] . flip ($))
b
bfenum :: Tree a -> [a]
= run (f t)
bfenum t where
Node x xs) = now x <> delay (foldMap f xs) f (
```

At this point, our type is starting to look a lot like the `Phases`

type from Noah Easterly’s tree-traversals package. This is exciting: the
`Phases`

type has the ideal interface for level-wise
traversals. Unfortunately, it has the wrong time complexity for
`<*>`

and so on: my suspicion is that the queue type
above here is to `Phases`

as the continuation monad is to the
free monad. In other words, we’ll get efficient construction at the
expense of no inspection. Unfortunately, I can’t figure out how to turn
the above type into an applicative. Maybe in a future post!

Finally, a lot of this is working towards finally understanding Smith (2009) and Allison (2006).

*Software: Practice and Experience*19 (2) (October): 99–109. doi:10.1002/spe.4380190202. http://users.monash.edu/~lloyd/tildeFP/1989SPE/.

*Stack Overflow*. https://stackoverflow.com/q/27748526.

*The Monad.Reader*14 (14) (July): 28. https://meldingmonads.files.wordpress.com/2009/06/corecqueues.pdf.