具有不同类型中断的有状态循环

Question

我正在尝试将以下有状态命令式代码转换为 Haskell。

while (true) {
  while (get()) {
    if (put1()) {
      failImmediately();
    }
  }
  if (put2()) {
    succeedImmediately();
  }
}

put1 和 put2 都读取系统的状态并对其进行修改。 get 可以为简单起见读取状态。 failImmediately 应该跳出无限循环并呈现一种结果，succeedImmediately 也应该跳出但呈现不同的结果。

我尝试使用的是State Env Result，其中Env 表示环境状态，Result 类似于Either Failure Success，用于某些自定义Failure 和Success。

一旦产生其中一个（打破循环），整个结果表达式应该折叠到Failure/Success 中，否则继续运行。

我的一个想法是使用Either Exit () where data Exit = Success | Failure 并使用StateT 以某种方式对Either 的Left 进行操作，就好像Either 是被链接的monad，即忽略任何后续操作。

如果能获得与上述 sn-p 相同的行为，我将非常感谢任何灵感或 Haskell 代码示例。

编辑：改进版移至单独的问题“Stateful computation with different types of short-circuit (Maybe, Either)”。

Answer 1

使用@chi 的答案中的套件，只是强调您不需要ContT 的全部功能，EitherT 的直接短路语义就足够了：

import Control.Monad.Trans.Either

data Result a = Failure | Success a

foo :: EitherT (Result Int) IO Int
foo = forever $ do
    whileM get $ do
        whenM put1 $ do
            left Failure
    whenM put2 $ do
        left $ Success 42

run :: (Monad m) => EitherT (Result a) m a -> m (Maybe a)
run act = do
    res <- runEitherT act
    return $ case res of
        Left Failure -> Nothing
        Left (Success x) -> Just x
        Right x -> Just x

-- whenM / whileM and get/put1/put2 as per @chi's answeer

Answer 2

几乎是字面意思，不优雅但有效的翻译。

我们利用ContT monad 转换器来实现 “早日归来”。即，我们希望能够在任何时候打破我们的循环。这是通过使用callCC $ \exit -> ... 来实现的，这大致使exit 成为我们的神奇函数，让我们立即逃离内部块。

import Control.Monad.Cont

action :: IO String
action = flip runContT return $ callCC $ \exit -> 
   forever $ do                   -- while (true)
      let loop = do
             r1 <- lift $ get     -- if (get())
             when r1 $ do
                r2 <- lift $ put1
                when r2 $         -- if (put1())
                   exit "failImmediately"
                loop              -- "repeat while"
      loop
      r3 <- lift $ put2
      when r3 $
         exit "succeedImmediately"

get :: IO Bool
get = readLn

put1 :: IO Bool
put1 = putStrLn "put1 here" >> readLn

put2 :: IO Bool
put2 = putStrLn "put2 here" >> readLn

main :: IO ()
main = action >>= putStrLn

我们还可以定义一些自定义助手来美化代码：

action2 :: IO String
action2 = flip runContT return $ callCC $ \exit -> 
   forever $ do                -- while (true)
      whileM get $             -- while(get())
         whenM put1 $          -- if (put1())
            exit "failImmediately"
      whenM put2 $             -- if (put2())
         exit "succeedImmediately"

whenM :: (MonadTrans t, Monad m, Monad (t m)) => m Bool -> t m () -> t m ()
whenM condition a = do
   r <- lift condition
   when r a

whileM :: (MonadTrans t, Monad m, Monad (t m)) => m Bool -> t m () -> t m ()
whileM condition a = whenM condition (a >> whileM condition a)