ネストしたコンピュテーション式に対応

gistfile1.fs

type SimpleBuilder () =
  member __.Return(x) = x
  member __.Bind(x, f) = f x

let simple = SimpleBuilder()

open Microsoft.FSharp.Quotations.Patterns
open System.Collections.Generic
open FSharp.Quotations.Evaluator

module Reducer =
  open Microsoft.FSharp.Quotations
  let mutable private i = 0
  let private valueMap = Dictionary<obj, string>()
  let printKnownVar obj =
    if obj = box simple then
      "simple"
    else
      "unknown_var"
  let printValues () =
    valueMap
    |> Seq.sortBy (fun kv -> kv.Value.Substring(2) |> int)
    |> Seq.map (fun kv -> sprintf "let %s: %s = %s" kv.Value (kv.Key.GetType().Name) (printKnownVar kv.Key))
  let rec reduce (expr: Expr) =
    match expr with
    | Call (Some receiver, m, args) ->
        (* インスタンスメソッド呼び出しを文字列化 *)
        let receiverStr, receiver = reduce receiver
        let args = List.map reduce args
        let argsStr = args |> List.map fst |> String.concat ", "
        let args = args |> List.map snd
        (sprintf "%s.%s(%s)" receiverStr m.Name argsStr), Expr.Call(receiver, m, args)
    | Value (obj, typ) ->
        (* 値を文字列化 *)
        if typ = typeof<SimpleBuilder> then
          (* 値が辞書にあったらそれを変数として扱うように変更 *)
          match valueMap.TryGetValue(obj) with
          | true, name -> name, expr
          | false, _ ->
              let name = sprintf "$b%d" i
              i <- i + 1
              valueMap.Add(obj, name)
              name, expr
        else
          (string obj), expr
    | Lambda (arg, Let(var, value, body)) when arg.Name = (reduce >> fst) value ->
        (* ラムダ式を文字列化 *)
        let arg = var.Name
        let bodyStr, body = reduce body
        (sprintf "(fun %s -> %s)" arg bodyStr), Expr.Lambda(var, body)
    | Var v ->
        (* 変数を文字列化 *)
        v.Name, expr
    | Application (Lambda(arg, Call(Some (Var receiver), m, [Quote body])), (PropertyGet (None, value, []) as prop))
          when arg = receiver && m.Name = "Run" ->
        (* ネストしたコンピュテーション式の単純化(Runの呼び出しと、引数にネストしたクォート化を取り除く) *)
        reduce (Expr.Application(Expr.Lambda(arg, body), prop))
    | Application (Lambda(arg, body), value) ->
        (* 上で単純化されたインラインのラムダ式呼び出しを文字列化 *)
        (* (fun arg -> body) value というコードを、let arg = value in body として扱う *)
        let bodyStr, body = reduce body
        let valueStr, value = reduce value
        (sprintf "let %s = %s in %s" arg.Name valueStr bodyStr), Expr.Application(Expr.Lambda(arg, body), value)
    | PropertyGet (None, p, []) ->
        (* プロパティアクセスを文字列化 *)
        p.Name, expr
    | _ ->
        (* 対応できない式木はエラーにするように変更 *)
        failwithf "%A is not supported." expr

type SimpleBuilder with
  member __.Quote () = ()
  member __.Run(expr: Quotations.Expr<'T>) =
    let exprStr, expr = Reducer.reduce expr
    let values = Reducer.printValues ()
    values |> Seq.iter (printfn "%s")
    printfn "%s" exprStr
    expr.EvaluateUntyped() :?> 'T

[<EntryPoint>]
let main argv =
  let res = simple {
    let! x = simple { return 42 }
    return x
  }
  let _ = res + 2
  let res = SimpleBuilder () {
    let! x = 10
    let! y = simple { return x }
    return y
  }
  0