Church-encoded free monad for F# (64bit release build only)

ChruchFree.fs

type _1<'F, 'A> = interface end

type Bind<'F, 'R> =
  abstract member Apply: _1<'F, 'B> * ('B -> 'R) -> 'R

type Monad<'F> =
  abstract member Return : 'T -> _1<'F, 'T>
  abstract member Bind: _1<'F, 'A> * ('A -> _1<'F, 'B>) -> _1<'F, 'B>

type Free<'F, 'A> =
  abstract member Apply: ('A -> 'R) * (Bind<'F, 'R>) -> 'R

// Natural Transformation
type NT<'F, 'G> =
  abstract member Apply: _1<'F, 'T> -> _1<'G, 'T>

module Free =

  let done_ a = { new Free<_, _> with
    member this.Apply(ret, _) = ret a }

  let lift(f: _1<'F, 'A>): Free<'F, 'A> =
    { new Free<'F, 'A> with
      member this.Apply(ret, bind) = bind.Apply(f, ret) }

  let bind (f: _ -> Free<_, _>) (m: Free<_, _>) = { new Free<_, _> with
    member this.Apply(ret, bind) =
      let g a = (f a).Apply(ret, bind)
      m.Apply(g, bind) }

  let map f m = bind (f >> done_) m

  let (>>=) m f = bind f m

  let foldMap (f: NT<'F, 'G>) (m: Monad<_>) (free: Free<_, _>) =
    let g a = m.Return(a)
    let b = { new Bind<_, _> with
      member this.Apply(fx, next) = m.Bind(f.Apply(fx), next) }
    free.Apply(g, b)

type F0 = F0

type F0<'T> = {
  Apply : unit -> 'T
}
  with
    interface _1<F0, 'T>

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module F0 =

  let ofFunc f = { Apply = f }

  let toFunc f = f.Apply

  let map f f0 = { Apply = fun () -> f (f0.Apply ()) }

  let run (x: _1<F0, Free<F0, 'T>>) = (x :?> F0<Free<F0, _>>).Apply ()

type Trampoline<'T> = Free<F0, 'T>

module Trampoline =

  let suspend (f: unit -> Trampoline<'T>) : Trampoline<_> =
    f |> F0.ofFunc |> Free.lift |> Free.bind id

  let delay f : Trampoline<_> = suspend (fun () -> Free.done_ (f ()))

type Id = Id

type Id<'T> = {
  Value : 'T
}
  with
    interface _1<Id, 'T>

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Id =

  let map f i = { Value = f i.Value }

  let bind (f: _ -> _1<Id, _>) i = f i.Value

  let monad = { new Monad<Id> with
    member this.Return(a) = { Value = a } :> _1<Id, _>
    member this.Bind(fa, f) = fa :?> Id<_> |> bind f }

  let run i = i.Value

type FreeBuilder () =
  member this.Return(x) = Free.done_ x
  member this.ReturnFrom(x) = x
  member this.Bind(x, f) = Free.bind f x

let free = FreeBuilder()

// test
let private f0IdNT = { new NT<F0, Id> with
  member x.Apply(f: _1<F0,'T>): _1<Id,'T> = { Id.Value = (f :?> F0<'T>).Apply() } :> _1<Id, _> }

let run a = a |> Free.foldMap f0IdNT Id.monad :?> Id<_> |> Id.run

let rec fib n =
  if n < 2M then Free.done_ n
  else
    free {
      let! x = Trampoline.suspend (fun () -> fib (n - 1M))
      let! y = Trampoline.suspend (fun () -> fib (n - 2M))
      return x + y
    }
    
fib 35M |> run