用状态单子打结

Question

我正在处理一个涉及打结的 Haskell 项目：我正在解析图形的序列化表示，其中每个节点都位于文件的某个偏移量处，并且可能通过其偏移量引用另一个节点。所以我需要在解析时建立一个从偏移量到节点的映射，我可以在 do rec 块中反馈给自己。

我有这个工作，并且有点-sorta-reasonably抽象成一个StateT-esque monad转换器：

{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving #-}

import qualified Control.Monad.State as S

data Knot s = Knot { past :: s, future :: s }

newtype RecStateT s m a = RecStateT (S.StateT (Knot s) m a) deriving
  ( Alternative
  , Applicative
  , Functor
  , Monad
  , MonadCont
  , MonadError e
  , MonadFix
  , MonadIO
  , MonadPlus
  , MonadReader r
  , MonadTrans
  , MonadWriter w )

runRecStateT :: RecStateT s m a -> Knot s -> m (a, Knot s)
runRecStateT (RecStateT st) = S.runStateT st

tie :: MonadFix m => RecStateT s m a -> s -> m (a, s)
tie m s = do
  rec (a, Knot s' _) <- runRecStateT m (Knot s s')
  return (a, s')

get :: Monad m => RecStateT s m (Knot s)
get = RecStateT S.get

put :: Monad m => s -> RecStateT s m ()
put s = RecStateT $ S.modify $ \ ~(Knot _ s') -> Knot s s'

tie 函数是魔法发生的地方：对runRecStateT 的调用会产生一个值和一个状态，我将其作为它自己的未来来提供。请注意，get 允许您读取过去和未来的状态，但 put 只允许您修改“现在”。

问题 1：总的来说，这似乎是实现这种打结模式的一种不错的方式吗？或者更好的是，是否有人对此实施了通用解决方案，而我在窥探 Hackage 时忽略了这一点？我在Cont monad 上打了一阵子，因为它看起来可能更优雅（参见 Dan Burton 的 similar post），但我就是搞不定。

完全主观的问题 2：我对调用代码的最终外观并不十分满意：

do
  Knot past future <- get
  let {- ... -} = past
      {- ... -} = future
      node = {- ... -}
  put $ {- ... -}
  return node

这里省略了实现细节，很明显，重要的一点是我必须获得past 和future 状态，模式匹配它们在一个 let 绑定中（或者明确地使前面的模式懒惰）提取我关心的任何内容，然后构建我的节点，更新我的状态并最终返回节点。似乎不必要地冗长，我特别不喜欢意外地使提取past 和future 状态的模式变得严格。那么，有人能想到更好的界面吗？

Answer 1

我一直在玩弄一些东西，我想我想出了一些……有趣的东西。我称它为“Seer”monad，它提供（除了 Monad 操作之外）两个原始操作：

see  :: Monoid s => Seer s s
send :: Monoid s => s -> Seer s ()

还有一个运行操作：

runSeer :: Monoid s => Seer s a -> a

这个 monad 的工作方式是 see 允许先知看到一切，而send 允许先知“发送”信息给所有其他先知以供他们看到。每当任何先知执行see 操作时，他们都能够看到所有已发送的信息，以及所有将要发送的信息。换句话说，在给定的运行中，see 将始终产生相同的结果，无论您在何时何地调用它。另一种说法是see 是您获得对“打结”结的有效参考的方式。

这实际上与仅使用fix 非常相似，只是所有子部分都是增量和隐式添加的，而不是显式添加的。显然，在存在悖论的情况下，先知将无法正常工作，需要足够的惰性。例如，see >>= send 可能会导致信息爆炸，使您陷入时间循环。

一个愚蠢的例子：

import Control.Seer
import qualified Data.Map as M
import Data.Map (Map, (!))

bar :: Seer (Map Int Char) String
bar = do
  m <- see
  send (M.singleton 1 $ succ (m ! 2))
  send (M.singleton 2 'c')
  return [m ! 1, m ! 2]

正如我所说，我只是在玩弄，所以我不知道这是否比你所拥有的更好，或者它是否有任何好处！但它很漂亮，也很相关，如果你的“结”状态是Monoid，那么它可能对你有用。公平警告：我使用 Tardis 构建了 Seer。

https://github.com/DanBurton/tardis/blob/master/Control/Seer.hs

Answer 2

我在题为Assembly: Circular Programming with Recursive do 上写了一篇关于这个主题的文章，其中我描述了使用打结来构建汇编程序的两种方法。与您的问题一样，汇编程序必须能够解析文件中稍后可能出现的标签地址。

Answer 3

关于实现，我会将其设为 Reader monad（用于未来）和 State monad（用于过去/现在）的组合。原因是您只设置了一次未来（在tie），然后不要更改它。

{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving #-}

import Control.Monad.State
import Control.Monad.Reader
import Control.Applicative

newtype RecStateT s m a = RecStateT (StateT s (ReaderT s m) a) deriving
  ( Alternative
  , Applicative
  , Functor
  , Monad
  , MonadPlus
  )

tie :: MonadFix m => RecStateT s m a -> s -> m (a, s)
tie (RecStateT m) s = do
  rec (a, s') <- flip runReaderT s' $ flip runStateT s m
  return (a, s')

getPast :: Monad m => RecStateT s m s
getPast = RecStateT get

getFuture :: Monad m => RecStateT s m s
getFuture = RecStateT ask

putPresent :: Monad m => s -> RecStateT s m ()
putPresent = RecStateT . put

关于您的第二个问题，了解您的数据流会有所帮助（即有一个最小的代码示例）。严格的模式总是导致循环是不正确的。确实需要小心，以免创建非生产循环，但确切的限制取决于您要构建的内容和方式。

Answer 4

我最近遇到了类似的问题，但我选择了不同的方法。递归数据结构可以表示为数据类型函子上的类型固定点。然后可以将加载数据分为两部分：

• 将数据加载到仅通过某种标识符引用其他节点的结构中。在示例中为Loader Int (NodeF Int)，它构造了一个NodeF Int Int 类型值的映射。
• 通过将标识符替换为实际数据来创建递归数据结构来打结。在示例中，生成的数据结构的类型为 Fix (NodeF Int)，为了方便起见，它们稍后被转换为 Node Int。

它缺乏适当的错误处理等，但这个想法应该很清楚。

-- Public Domain

import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)

-- Fixed point operator on types and catamohism/anamorphism methods
-- for constructing/deconstructing them:

newtype Fix f = Fix { unfix :: f (Fix f) }

catam :: Functor f => (f a -> a) -> (Fix f -> a)
catam f = f . fmap (catam f) . unfix

anam :: Functor f => (a -> f a) -> (a -> Fix f)
anam f = Fix . fmap (anam f) . f

anam' :: Functor f => (a -> f a) -> (f a -> Fix f)
anam' f = Fix . fmap (anam f)

-- The loader itself

-- A representation of a loader. Type parameter 'k' represents the keys by
-- which the nodes are represented. Type parameter 'v' represents a functor
-- data type representing the values.
data Loader k v = Loader (Map k (v k))

-- | Creates an empty loader.
empty :: Loader k v
empty = Loader $ Map.empty

-- | Adds a new node into a loader.
update :: (Ord k) => k -> v k -> Loader k v -> Loader k v
update k v = update' k (const v)

-- | Modifies a node in a loader.
update' :: (Ord k) => k -> (Maybe (v k) -> (v k)) -> Loader k v -> Loader k v
update' k f (Loader m) = Loader $ Map.insertWith (const (f . Just)) k (f Nothing) $ m

-- | Does the actual knot-tying. Creates a new data structure
-- where the references to nodes are replaced by the actual data.
tie :: (Ord k, Functor v) => Loader k v -> Map k (Fix v)
tie (Loader m) = Map.map (anam' $ \k -> fromJust (Map.lookup k m)) m


-- -----------------------------------------------------------------
-- Usage example:

data NodeF n t = NodeF n [t]
instance Functor (NodeF n) where
    fmap f (NodeF n xs) = NodeF n (map f xs)

-- A data structure isomorphic to Fix (NodeF n), but easier to work with.
data Node n = Node n [Node n]
  deriving Show
-- The isomorphism that does the conversion.
nodeunfix :: Fix (NodeF n) -> Node n
nodeunfix = catam (\(NodeF n ts) -> Node n ts)

main :: IO ()
main = do
    -- Each node description consist of an integer ID and a list of other nodes
    -- it references.
    let lss = 
            [ (1, [4])
            , (2, [1])
            , (3, [2, 1])
            , (4, [3, 2, 1])
            , (5, [5])
            ]
    print lss
    -- Fill a new loader with the data:
    let
        loader = foldr f empty lss
        f (label, dependsOn) = update label (NodeF label dependsOn)
    -- Tie the knot:
    let tied' = tie loader
    -- And convert Fix (NodeF n) into Node n:
    let tied = Map.map nodeunfix tied'

    -- For each node print the label of the first node it references
    -- and the count of all referenced nodes.
    print $ Map.map (\(Node n ls@((Node n1 _) : _)) -> (n1, length ls)) tied

Answer 5

Monad 的使用量让我有点不知所措。 我可能不理解过去/未来的事情，但我猜你只是想表达惰性+固定点绑定。 （如果我错了纠正我。） R=W 的RWS Monad 用法有点有趣，但你不需要State 和loop，你可以用fmap 做同样的事情。如果 Monads 不能让事情变得更容易，那么使用 Monads 是没有意义的。 （无论如何，只有极少数 Monad 代表时间顺序。）

我打结的一般解决方案：

1. 我将所有内容解析到一个节点列表，
2. 将该列表转换为 Data.Vector 以便 O(1) 访问装箱（=惰性）值，
3. 使用let 或fix 或mfix 函数将该结果绑定到名称，
4. 并在解析器中访问名为Vector。 （见 1.）

---

example 解决方案在您的blog 中，您在其中编写某事。像这样：

data Node = Node {
  value :: Int,
  next  :: Node
} deriving Show
…
tie = …
parse = …
data ParserState = …
…
example :: Node
example =
  let (_, _, m) = tie parse $ ParserState 0 [(0, 1), (1, 2), (2, 0)]
  in (m Map.! 0)

我会这样写：

{-# LANGUAGE ViewPatterns, NamedFieldPuns #-}
import Data.Vector as Vector

example :: Node
example =
   let node :: Int -> Node
       node = (Vector.!) $ Vector.fromList $
                   [ Node{value,next}
                   | (value,node->next) <- [(0, 1), (1, 2), (2, 0)]
                   ]
   in (node 0)

或更短：

{-# LANGUAGE ViewPatterns, NamedFieldPuns #-}
import Data.Vector as Vector

example :: Node
example = (\node->(Vector.fromList[ Node{value,next}
                                  | (value,node->next) <- [(0, 1), (1, 2), (2, 0)]
                                  ] Vector.!)) `fix` 0