asynchronous - F# 异步工作流/任务结合免费 monad

Question

我正在尝试使用免费 monad 模式构建消息处理管道，我的代码如下所示:

module PipeMonad =
type PipeInstruction<'msgIn, 'msgOut, 'a> =
    | HandleAsync of 'msgIn * (Async<'msgOut> -> 'a)
    | SendOutAsync of 'msgOut * (Async -> 'a)

let private mapInstruction f = function
    | HandleAsync (x, next) -> HandleAsync (x, next >> f)
    | SendOutAsync (x, next) -> SendOutAsync (x, next >> f)

type PipeProgram<'msgIn, 'msgOut, 'a> =
    | Act of PipeInstruction<'msgIn, 'msgOut, PipeProgram<'msgIn, 'msgOut, 'a>>
    | Stop of 'a

let rec bind f = function
    | Act x -> x |> mapInstruction (bind f) |> Act
    | Stop x -> f x

type PipeBuilder() =
    member __.Bind (x, f) = bind f x
    member __.Return x = Stop x
    member __.Zero () = Stop ()
    member __.ReturnFrom x = x

let pipe = PipeBuilder()
let handleAsync msgIn = Act (HandleAsync (msgIn, Stop))
let sendOutAsync msgOut = Act (SendOutAsync (msgOut, Stop))

我根据 this article 写的

然而，让这些方法异步对我来说很重要( Task 最好，但 Async 是可以接受的)，但是当我为我的 pipeline 创建一个构建器时，我不知道如何使用它 - 我如何等待 Task<'msgOut>或 Async<'msgOut>所以我可以发送它并等待这个“发送”任务？

现在我有这段代码:

let pipeline log msgIn =
    pipe {
        let! msgOut = handleAsync msgIn
        let result = async {
            let! msgOut = msgOut
            log msgOut
            return sendOutAsync msgOut
        }
        return result
    }

返回 PipeProgram<'b, 'a, Async<PipeProgram<'c, 'a, Async>>>

Answer 1

在我的理解中，free monad 的全部意义在于你不暴露像 Async 这样的效果，所以我认为它们不应该用在 PipeInstruction 类型中。解释器是添加效果的地方。

此外，Free Monad 真的只在 Haskell 中有意义，你需要做的就是定义一个仿函数，然后你会自动获得其余的实现。在 F# 中，您还必须编写其余的代码，因此与更传统的解释器模式相比，使用 Free 并没有太大好处。
您链接到的 TurtleProgram 代码只是一个实验——我根本不建议将 Free 用于真正的代码。

最后，如果您已经知道将要使用的效果，并且不会有多种解释，那么使用这种方法就没有意义了。只有当 yield 大于复杂性时才有意义。

无论如何，如果您确实想编写一个解释器版本(而不是免费的)，我会这样做:

首先，定义没有任何影响的指令。

/// The abstract instruction set
module PipeProgram =

    type PipeInstruction<'msgIn, 'msgOut,'state> =
        | Handle of 'msgIn * ('msgOut -> PipeInstruction<'msgIn, 'msgOut,'state>)
        | SendOut of 'msgOut * (unit -> PipeInstruction<'msgIn, 'msgOut,'state>)
        | Stop of 'state

然后你可以为它写一个计算表达式:

/// A computation expression for a PipeProgram
module PipeProgramCE =
    open PipeProgram

    let rec bind f instruction =
        match instruction with
        | Handle (x,next) ->  Handle (x, (next >> bind f))
        | SendOut (x, next) -> SendOut (x, (next >> bind f))
        | Stop x -> f x

    type PipeBuilder() =
        member __.Bind (x, f) = bind f x
        member __.Return x = Stop x
        member __.Zero () = Stop ()
        member __.ReturnFrom x = x

let pipe = PipeProgramCE.PipeBuilder()

然后您就可以开始编写计算表达式了。这将有助于在开始解释器之前清除设计。

// helper functions for CE
let stop x = PipeProgram.Stop x
let handle x = PipeProgram.Handle (x,stop)
let sendOut x  = PipeProgram.SendOut (x, stop)

let exampleProgram : PipeProgram.PipeInstruction<string,string,string> = pipe {
    let! msgOut1 = handle "In1"
    do! sendOut msgOut1
    let! msgOut2 = handle "In2"
    do! sendOut msgOut2
    return msgOut2
    }

一旦你描述了指令，你就可以编写解释器了。正如我所说，如果您没有编写多个解释器，那么也许您根本不需要这样做。

这是一个非异步版本的解释器(就像“Id monad”一样):

module PipeInterpreterSync =
    open PipeProgram

    let handle msgIn =
        printfn "In: %A"  msgIn
        let msgOut = System.Console.ReadLine()
        msgOut

    let sendOut msgOut =
        printfn "Out: %A"  msgOut
        ()

    let rec interpret instruction =
        match instruction with
        | Handle (x, next) ->
            let result = handle x
            result |> next |> interpret
        | SendOut (x, next) ->
            let result = sendOut x
            result |> next |> interpret
        | Stop x ->
            x

这是异步版本:

module PipeInterpreterAsync =
    open PipeProgram

    /// Implementation of "handle" uses async/IO
    let handleAsync msgIn = async {
        printfn "In: %A"  msgIn
        let msgOut = System.Console.ReadLine()
        return msgOut
        }

    /// Implementation of "sendOut" uses async/IO
    let sendOutAsync msgOut = async {
        printfn "Out: %A"  msgOut
        return ()
        }

    let rec interpret instruction =
        match instruction with
        | Handle (x, next) -> async {
            let! result = handleAsync x
            return! result |> next |> interpret
            }
        | SendOut (x, next) -> async {
            do! sendOutAsync x
            return! () |> next |> interpret
            }
        | Stop x -> x