一棵一元玫瑰树能有一个MonadFix实例吗？

Question

给定的

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

是否有一个有效的MonadFix实例？

我的尝试是

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

然而，当我尝试使用它时，它似乎并没有终止。该实例在某种程度上受到列表的MonadFix实例的启发。

Answer 1

真正的解决方案确实来自加利瓦，只需做一个小小的修改。我们还将核心思想提升到了containers库中，使用了MonadFix Tree实例这里

{-# 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