Как я могу реализовать этот монадный трансформатор с продолжением?

мотивация. Я пытаюсь создать монадный трансформатор со специальной командой 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"
---

вопрос. Есть ли чистый способ достичь вышеуказанного поведения с помощью какого-то продолжения переходного монадного трансформатора? Я посмотрел на Олега и др. "Backtracking, Interleaving и Terminating Monad Transformers", но, похоже, не могут полностью понять их реализацию (как только они дойдут до реализации msplit с продолжением).

текущая реализация. Моя текущая реализация состоит в том, чтобы передать список решений для ветвления. Монада вернет список ветвей, которые он на самом деле выбирает, а затем в следующий раз мы переключим последнюю возможную ветвь. Код выглядит следующим образом (должен работать в 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 [email protected](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)

Ответы

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

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

f <||> g = ContT $ \k -> do
  xs <- runContT f k
  ys <- runContT g k
  return $ xs ++ ys

test = runContT computation (return . (:[]))

"start -- always"
"first choice"
"intermediate -- always"
"third choice"
"end -- always"
"fourth choice"
"end -- always"
"second choice"
"intermediate -- always"
"third choice"
"end -- always"
"fourth choice"
"end -- always"