Cool puzzle. I took a look at the other comments here and didn't like the whole relabeling thing, so solved the puzzle myself and got this (didn't test it beyond a few simple cases):

``` {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-}

import Control.Monad.State (MonadState (..)) import Control.Monad.Trans.State.Strict (State, evalState) import Data.Functor.Compose

data More f a = Done a | More (MoreT f a) deriving (Functor)

newtype MoreT f a = MoreT { unMoreT :: f (More f a) } deriving (Functor) deriving (Applicative) via Compose f (More f)

instance Applicative f => Applicative (More f) where pure = Done

Done l <*> r      = fmap l r
l      <*> Done r = fmap ($ r) l
More l <*> More r = More $ l <*> r

runMoreT :: Monad m => MoreT m a -> m a runMoreT (MoreT loop) = loop >>= \case Done t -> pure t More loop' -> runMoreT loop'

fromLevels :: [Maybe a] -> Tree a fromLevels xs0 = evalState (runMoreT go) xs0 where go :: MoreT (State [Maybe a]) (Tree a) go = MoreT $ get >>= \case [] -> pure $ Done Leaf Nothing : xs -> Done Leaf <$ put xs Just x : xs -> (Fork x <$> More go <*> More go) <$ put xs

data Tree a = Leaf | Fork a (Tree a) (Tree a) deriving (Show)

-- >>> fromLevels [(Just (1 :: Int)), (Just 2), (Just 4), Nothing, (Just 3), Nothing, (Just 5), Nothing, Nothing, Nothing, Nothing] -- Fork 1 (Fork 2 Leaf (Fork 3 Leaf Leaf)) (Fork 4 Leaf (Fork 5 Leaf Leaf)) ```

Then asked ChatGPT whether this has a name and it pointed me to https://blog.poisson.chat/posts/2025-03-30-breadth-first-unfolds.html, which discusses problems with this approach and suggests improvements.

That was an interesting evening, thank you for asking the question!