一棵单子玫瑰树可以有一个 MonadFix 实例吗？答案

【问题标题】：Can a monadic rose tree have a MonadFix instance?一棵单子玫瑰树可以有一个 MonadFix 实例吗？
【发布时间】：2018-05-29 17:07:47
【问题描述】：

给定

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 列表实例的启发。

【问题讨论】：

Monad (Tree m) 的开头是什么样的？
好的，然后I may have something for you。它基于我对MonadFix [] 的理解：在f 上使用fix 来获取顶层的形状，并通过在子位置上递归调用mfix 来生成子树，并修改f 以针对每个子位置准确定位。我非常有信心它为Tree Identity 做正确的事情，但是我不相信我不会过早地强迫一些m 行动，因为我推断是Tree m 的语义。
@gallais 我认为这是解决方法：gist.github.com/ocharles/9b6fb71669de4533373a9c7f1f3ce8f9。您需要mfix 而不是fix，因此m 也必须是MonadFix。这至少满足了我在IO 中的上述示例。
这种类型闻起来很像FreeT []。是吗？如果是这样，如果你给的实例是有效的，在什么情况下FreeT f m可以有一个有效的MonadFix实例？
@ocharles，啊，是的，我将总和与产品混合在一起。请把我的问题应用到我应该指的类型上！

标签： haskell data-structures monads monadfix

【解决方案1】：

真正的解决方案真的来自gallais，稍加修改。我们也将核心思想提升到containers 库中，使用MonadFix Tree 实例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

【讨论】：