haskelldata-structuresmonadsmonadfix

Can a monadic rose tree have a MonadFix instance?


Given

newtype Tree m a = Tree { runTree :: m (Node m a) }
data Node m a = Node
  { nodeValue :: a
  , nodeChildren :: [Tree m a] 
  }

Is there a valid MonadFix instance?

My attempt was

instance MonadFix m => MonadFix (Tree m) where
  mfix f = Tree $ do
    Node
      <$> mfix (runTree . f . nodeValue) 
      <*> fmap nodeChildren (runTree (mfix f))

Yet this doesn't seem to terminate when I actually try and use it. The instance is somewhat inspired by the MonadFix instance for lists.


Solution

  • The real solution really comes from gallais with a small modification. We lifted the core idea out into the containers library too, with MonadFix Tree instance here

    {-# LANGUAGE DeriveFunctor #-}
    
    module MonadTree where
    
    import Control.Monad
    import Control.Monad.Fix
    
    newtype Tree m a = Tree { runTree :: m (Node m a) }
      deriving (Functor)
    
    data Node m a = Node
      { nodeValue :: a
      , nodeChildren :: [Tree m a]
      } deriving (Functor)
    
    valueM :: Functor m => Tree m a -> m a
    valueM = fmap nodeValue . runTree
    
    childrenM :: Functor m => Tree m a -> m [Tree m a]
    childrenM = fmap nodeChildren . runTree
    
    joinTree :: Monad m => m (Tree m a) -> Tree m a
    joinTree = Tree . join . fmap runTree
    
    instance Monad m => Applicative (Tree m) where
      pure a = Tree $ pure $ Node a []
      (<*>)  = ap
    instance Monad m => Monad (Tree m) where
      return = pure
      m >>= k =
        Tree $ do
          Node x xs <- runTree m
          Node y ys <- runTree (k x)
          pure . Node y $
            fmap (>>= k) xs ++ ys
    
    instance MonadFix m => MonadFix (Tree m) where
      mfix f = Tree $ do
        node <- mfix $ \a -> do
          runTree (f (nodeValue a))
        let value = nodeValue node
        let trees = nodeChildren node
        let children = zipWith (\ k _ -> mfix (joinTree . fmap (!! k) . childrenM . f)) [0..] trees
        return $ Node value children