具有不同类型短路的状态计算（Maybe，Either）

Question

我试图找到将以下有状态的命令式代码转换为纯函数表示的最优雅的方法（最好在 Haskell 中使用其 Monad 实现提供的抽象）。但是，我还不擅长使用变压器等组合不同的单子。在我看来，分析他人对此类任务的看法对自己学习如何做最有帮助。命令式代码：

while (true) {
  while (x = get()) { // Think of this as returning Maybe something
    put1(x) // may exit and present some failure representation
  }
  put2() // may exit and present some success representation
}

当get 返回Nothing 时，我们需要继续执行put2，当get 返回Just x 时，我们希望x 传递给put1，并且仅在@ 时短路987654331@ 失败或循环。基本上put1 和put2 可能会终止整个事情或移动到以下语句以某种方式改变底层状态。 get 可以成功并调用put1 并循环或失败并继续put2。

我的想法是这样的：

forever $ do
  forever (get >>= put1)
  put2

而我之所以要寻找类似的东西是因为(get >>= put1) 可以在get 没有任何返回或put1 终止时简单地短路。同样put2 终止外循环。但是我不确定如何将State 与必要的Maybe 和/或Either 混合以实现此目的。

我认为使用转换器来组合State 和其他单子是必要的，因此代码很可能不会那么简洁。但我想它也可能不会更糟。

欢迎任何关于如何优雅地实现翻译的建议。这与“Stateful loop with different types of breaks”的不同之处在于避免使用if、when、while 进行显式控制流，而是试图鼓励使用Maybe、Either 或其他一些方便的>>= 语义。此外，总有一种直接的方法可以将代码转换为函数式代码，但它很难被认为是优雅的。

Answer 1

这可能与@Cirdec 的回答有些重叠，但它也可以帮助您更好地了解正在发生的事情。

首先要注意的是，您实际上没有双重嵌套循环。如果没有退出语句，您可以将其编写为一个简单的循环：

example1 = forever $ do
  x <- getNext                -- get the next String
  if (isPrefixOf "break-" x)  -- do we break out of the "inner" loop?
    then put2 x
    else put1 x
  where
    put1 x = putStrLn $ "put1: " ++ x
    put2 x = putStrLn $ "put2: " ++ x

所以现在我们只需使用标准技术，即使用runEitherT 来打破循环。

首先是一些导入：

import Control.Monad
import Control.Monad.Trans.Either
import Control.Monad.State.Strict
import Data.List

以及我们的结果类型和便利函数：

data Result = Success String | Fail String deriving (Show)

exit = left

然后我们重写我们的循环以解除任何 IO 操作，并在我们想要跳出循环时使用 exit：

example2 match =
  let loop = runEitherT $ forever $ do
        x <- getNext
        if isPrefixOf "break-" x
          then put2 x
          else put1 x
        where
          put1 "fail" = exit (Fail "fail encountered")
          put1 x      = liftIO $ putStrLn $ "put1: " ++ x

          put2 x      = if x == match
                          then exit (Success $ "found " ++ match)
                          else liftIO $ putStrLn $ "put2: " ++ x
  in loop

这里有一些测试：

-- get next item from the state list:
getNext = do (x:xs) <- get; put xs; return x

test2a = evalStateT (example2 "break-foo") [ "a", "b", "fail" ]
test2b = evalStateT (example2 "break-foo") [ "a", "b", "break-foo", "c", "fail" ]
test2c = evalStateT (example2 "break-foo") [ "a", "b", "break-xxx", "c", "fail" ]

这些测试的输出是：

ghci> test2a
put1: a
put1: b
Left (Fail "fail encountered")

ghci> test2b
put1: a
put1: b
Left (Success "found break-foo")

ghci> test2c
put1: a
put1: b
put2: break-xxx
put1: c
Left (Fail "fail encountered")

在此示例中，runEitherT 的返回值将始终为 Left r，其中 r 是 Result 值，因此调用这些示例之一的代码可能如下所示：

Left r <- test2a
case r of
  Success ... ->
  Fail    ... -> 

请注意，您可以使用 Either String String，而不是自定义 Result 类型：

type Result = Either String String

并使用Left 表示Fail 和Right 表示Success。

Answer 2

您正在寻找EitherT 或ExceptT。它增加了两种返回变压器堆栈的方法。计算可以是return a 或throwError e。错误和返回之间有两个区别。错误保存在Left 上并返回Right。当您>>= 遇到错误时，它会短路。

newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }

return :: a -> EitherT e m a
return a = EitherT $ return (Right a)

throwError :: e -> EitherT e m a
throwError e = EitherT $ return (Left a)

我们还将使用名称left = throwError 和right = return。

Left 上的错误不会继续，我们将使用它们来表示退出循环。我们将使用类型EitherT r m () 来表示一个循环，该循环要么以中断结果Left r 停止，要么以Right () 继续。这几乎完全是forever，除了我们解开EitherT 并去掉返回值周围的Left。

import Control.Monad
import Control.Monad.Trans.Either

untilLeft :: Monad m => EitherT r m () -> m r
untilLeft = liftM (either id id) . runEitherT . forever   

在充实您的示例后，我们将回到如何使用这些循环。

由于您希望看到几乎所有的逻辑都消失了，我们也将使用EitherT 处理其他所有内容。获取数据的计算要么是Done要么返回数据。

import Control.Monad.Trans.Class
import Control.Monad.Trans.State

data Done = Done       deriving Show

-- Gets numbers for a while.
get1 :: EitherT Done (State Int) Int
get1 = do
    x <- lift get
    lift . put $ x + 1
    if x `mod` 3 == 0
    then left Done
    else right x

放入数据的第一个计算是 Failure 或返回。

data Failure = Failure deriving Show

put1 :: Int -> EitherT Failure (State Int) ()
put1 x = if x `mod` 16 == 0
         then left Failure
         else right ()

第二个放入数据的计算是 Success 或返回。

data Success = Success deriving Show

put2 :: EitherT Success (State Int) ()
put2 = do 
        x <- lift get
        if x `mod` 25 == 0
        then left Success
        else right ()

对于您的示例，我们将需要结合两个或多个计算，它们都以不同的方式异常停止。我们将用两个嵌套的EitherTs 来表示它。

EitherT o (EitherT i m) r

外部EitherT 是我们目前正在操作的那个。我们可以将EitherT o m a 转换为EitherT o (EitherT i m) a，方法是在每个m 周围添加一个额外的EitherT 层^†。

over :: (MonadTrans t, Monad m) => EitherT e m a -> EitherT e (t m) a
over = mapEitherT lift

内部EitherT 层将像变压器堆栈中的任何其他底层monad 一样被处理。我们可以 lift 和 EitherT i m a 到 EitherT o (EitherT i m) a

我们现在可以构建一个成功或失败的整体计算。会破坏当前循环的计算在over 中运行。会破坏外循环的计算是lifted。

example :: EitherT Failure (State Int) Success
example =
    untilLeft $ do
        lift . untilLeft $ over get1 >>= lift . put1
        over put2

总体而言，Failure 是 lift 两次进入最内层循环。这个例子很有趣，可以看到几个不同的结果。

main = print . map (runState $ runEitherT example) $ [1..30]

---

^†如果EitherT 有一个MFunctor 实例，那么over 就是hoist lift，这是一个经常使用的模式，它值得拥有一个经过深思熟虑的名称。顺便说一句，我使用EitherT 而不是ExceptT 主要是因为它的名称加载较少。无论哪一个首先提供MFunctor 实例，对我来说，最终都会胜出，成为任一monad 转换器。

Answer 3

你的问题有点棘手，因为你问的是一种不太优雅的优雅方式。有Control.Monad.Loops 来编写这种类型的循环。您可能需要whileJust' 或类似的东西。通常，我们不需要像这样编写while 循环，而普通的旧递归通常是最简单的。

我试图找到一个何时需要这种类型的代码的示例，我提供了以下示例。我想建立一个用户输入的字符串列表。每行对应于列表中的一个条目。一个空行开始一个新列表，两个空行停止循环。

例子

a
b
c

d
e

f

会给

[ ["a", "b", "c"
, ["d", "e"]
, ["f"]
]

我可能会在 haskell 中执行以下操作

readMat :: IO [[String]]
readMat = reverse `fmap` go [[]]
    where go sss = do
                s <- getLine
                case s of
                    "" -> case sss of
                        []:sss' -> return sss' # the end
                        _ -> go ([]:sss)       # starts a new line
                    _ -> let (ss:ss') = sss
                          in go ((ss ++ [s]):ss')

只是简单的递归。

Answer 4

但是我还不擅长使用转换器等组合不同的 monad。

您实际上不需要将不同的 monad 与组合子组合，您只需将 Maybe monad 显式嵌入 State monad 中。一旦完成，翻译 sn-p 就很简单了，用相互递归的函数替换循环——相互性实现了分支条件。

让我们用 OCaml 和 sparkling monad library Lemonade 编写一个解决方案，其中 State monad 被称为 Lemonade_Success。

所以，我假设 put1 和 put2 返回的表示错误的类型是字符串，表示诊断消息，我们在 String 类型上实例化 Success monad ：

Success =
  Lemonade_Success.Make(String)

现在，Success 模块代表一元计算，它可能会因诊断而失败。有关 Success 的完整签名，请参见下文。我写了上面 sn-p 的翻译，作为一个由你的数据参数化的函子，但当然，你可以缩短这个并直接使用实现定义。您的问题的数据由具有签名 P

的模块参数描述

module type P =
sig
    type t
    val get : unit -> t option
    val put1 : t -> unit Success.t
    val put2 : unit -> unit Success.t
end

上述 sn-p 的可能实现是

module M(Parameter:P) =
struct
    open Success.Infix

    let success_get () =
      match Parameter.get () with
        | Some(x) -> Success.return x
        | None -> Success.throw "Parameter.get"

    let rec innerloop () =
      Success.catch
        (success_get () >>= Parameter.put1 >>= innerloop)
        (Parameter.put2 >=> outerloop)
    and outerloop () =
      innerloop () >>= outerloop
end

函数 get_success 将 Maybe monad 映射到 Success monad，提供临时错误描述。这是因为您需要这种特殊的错误描述，您将无法仅使用抽象的 monad 组合子进行此转换 - 或者，更迂腐地说，没有从 Maybe 到 State 的规范映射，因为这些映射是参数化的通过错误描述。

编写 success_get 函数后，使用相互递归函数和 Success.catch 函数来转换您描述的分支条件非常简单，用于处理错误条件。

我把 Haskell 中的实现留给你作为练习。 :)

---

成功模块的完整签名是

  module Success :
  sig
    type error = String.t
    type 'a outcome =
      | Success of 'a
      | Error of error
    type 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val return : 'a -> 'a t
    val apply : ('a -> 'b) t -> 'a t -> 'b t
    val join : 'a t t -> 'a t
    val map : ('a -> 'b) -> 'a t -> 'b t
    val bind2 : 'a t -> 'b t -> ('a -> 'b -> 'c t) -> 'c t
    val bind3 : 'a t -> 'b t -> 'c t -> ('a -> 'b -> 'c -> 'd t) -> 'd t
    val bind4 :
      'a t -> 'b t -> 'c t -> 'd t -> ('a -> 'b -> 'c -> 'd -> 'e t) -> 'e t
    val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
    val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
    val map4 :
      ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t
    val dist : 'a t list -> 'a list t
    val ignore : 'a t -> unit t
    val filter : ('a -> bool t) -> 'a t list -> 'a list t
    val only_if : bool -> unit t -> unit t
    val unless : bool -> unit t -> unit t
    module Infix :
      sig
        val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t
        val ( <$> ) : ('a -> 'b) -> 'a t -> 'b t
        val ( <* ) : 'a t -> 'b t -> 'a t
        val ( >* ) : 'a t -> 'b t -> 'b t
        val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
        val ( >> ) : 'a t -> (unit -> 'b t) -> 'b t
        val ( >=> ) : ('a -> 'b t) -> ('b -> 'c t) -> 'a -> 'c t
        val ( <=< ) : ('b -> 'c t) -> ('a -> 'b t) -> 'a -> 'c t
      end
    val throw : error -> 'a t
    val catch : 'a t -> (error -> 'a t) -> 'a t
    val run : 'a t -> 'a outcome
  end

为了保持简洁，我删除了一些类型注释，并从签名中隐藏了自然转换 T。