如何实现这个monad变换器的延续？

Question

动机.我正在尝试创建一个monad变换器,其中包含一个特殊指令f <||> g,意思是"重复此整个块包含f <||> g,一次使用f,下一次使用g".这可以用于DSL转换,但您可以想象其他应用程序.

示例用法.该computation单子表达不同的可能的选择(在这种情况下,物联网打印).该printme函数说明了如何处理每个不同的结果.在这种情况下,我们在运行之前打印"开始计算",之后打印"---".

computation = do
    lift (print "start -- always")
    (lift (print "first choice") <||> lift (print "second choice"))
    lift (print "intermediate -- always")
    (lift (print "third choice") <||> lift (print "fourth choice"))
    lift (print "end -- always")

printme x = do
    putStrLn "=== start computation"
    xv <- x
    putStrLn "---\n"
    return xv

test = runIndep printme computation

输出如下,

=== start computation
"start -- always"
"first choice"
"intermediate -- always"
"third choice"
"end -- always"
---

=== start computation
"start -- always"
"first choice"
"intermediate -- always"
"fourth choice"
"end -- always"
---

=== start computation
"start -- always"
"second choice"
"intermediate -- always"
"third choice"
"end -- always"
---

=== start computation
"start -- always"
"second choice"
"intermediate -- always"
"fourth choice"
"end -- always"
---

问题.使用某种延续传递方式monad变换器有没有一种干净的方法来实现上述行为？我看过Oleg等人的"Backtracking,Interleaving,and Terminating Monad Transformers"论文,但似乎无法完全掌握它们的实现(一旦它们msplit实现了延续).

目前的实施.我目前的实现是传递一个分支决策列表.monad将返回它实际选择的分支列表,然后下次我们将切换最后一个可能的分支.代码如下(应该在7.0.3中运行),

import Control.Monad.Trans.Class

data IndepModelT  ? = IndepModelT {
    unIndepModelT :: [Bool] ->  (?, [Bool]) }

instance Monad  => Monad (IndepModelT ) where
    return x = IndepModelT $ \choices -> return (x, [])
    (IndepModelT x) >>= f = IndepModelT $ \choices -> do
        (xv, branches) <- x choices
        let choices' = drop (length branches) choices
        (fxv, branches') <- unIndepModelT (f xv) choices'
        return (fxv, branches ++ branches')

instance MonadTrans IndepModelT where
    lift x = IndepModelT $ \c -> liftWithChoice [] x
liftWithChoice cs mx = mx >>= \xv -> return (xv, cs)

(<||>)
  :: Monad  => IndepModelT  ? -> IndepModelT  ? -> IndepModelT  ?
(IndepModelT f) <||> (IndepModelT g) = IndepModelT go where
    go (False:cs) = do
        (fv, branches) <- f cs
        return (fv, False : branches)
    go (True:cs) = do
        (fv, branches) <- g cs
        return (fv, True : branches)

run_inner next_choices k comp@(IndepModelT comp_inner) = do
    (xv, branches) <- k $ comp_inner next_choices
    case (get_next_choices branches) of
        Nothing -> return ()
        Just choices -> run_inner (choices ++ repeat False) k comp
    where
        get_next_choices [] = Nothing
        get_next_choices [True] = Nothing
        get_next_choices [False] = Just [True]
        get_next_choices (c:cs)
            | Just cs' <- get_next_choices cs = Just $ c:cs'
            | c Prelude.== False = Just [True]
            | otherwise = Nothing

runIndep :: Monad  =>
    ( (?, [Bool]) ->  (?, [Bool]))
    -> IndepModelT  ?
    ->  ()
runIndep = run_inner (repeat False)

runIndepFirst (IndepModelT comp) = comp (repeat False)

Answer 1

这是问题所在:这不是一个单子!这种行为甚至没有明确定义.在这种情况下它应该做什么:

do
  b <- ...randomly True or False...
  if b then ...some choices... else ...some other choices...

但是,确实如此Applicative.我们需要的类型是[IO a]2个应用仿函数的组合,所以我们可以使用Data.Functor.Compose变压器包.这也为免费提供了一个Alternative实例<|>.我们将使用Rebindable Syntax为Applicative使用do-notation:

{-# LANGUAGE RebindableSyntax #-}
import Prelude hiding ((>>), (>>=))
import Control.Applicative
import Data.Functor.Compose

lift :: Applicative f => g a -> Compose f g a
lift = Compose . pure

(>>) :: Applicative f => f a -> f b -> f b
(>>) = (*>)

computation :: Alternative f => Compose f IO ()
computation = do
    lift (print "start -- always")
    lift (print "first choice") <|> lift (print "second choice")
    lift (print "intermediate -- always")
    lift (print "third choice") <|> lift (print "fourth choice")
    lift (print "end -- always")

printme x = do
    putStrLn "=== start computation"
    x
    putStrLn "---\n"

test = mapM printme $ getCompose computation