cell.fs

type ExecContext () =
  class
    // TODO: scheduler, storage
  end

[<AbstractClass>]
type Cont<'a> () =
  abstract RunCont : ExecContext * 'a -> unit

[<AbstractClass>]
type Cell<'a> () =
  abstract RunCell : ExecContext * Cont<'a> -> unit

/// Encases the monadic bind operation ('a -> Cell<'b>) -> Cell<'a> -> Cell<'b>
[<AbstractClass>]  
type CellBind<'a, 'b> () =
  inherit Cell<'b> ()
  
  [<DefaultValue>] 
  val mutable cellA : Cell<'a>
  
  member __.Init (c:Cell<'a>) =
    __.cellA <- c

  abstract DoBind : 'a -> Cell<'b>
  
  override __.RunCell (ctx:ExecContext, cont:Cont<'b>) = 
    __.cellA.RunCell (ctx, CellBindCont(__, cont))

and CellBindCont<'a, 'b> (cb:CellBind<'a, 'b>, contB:Cont<'b>) =
  inherit Cont<'a> ()
  override __.RunCont (ctx, a:'a) = 
    cb.DoBind(a).RunCell (ctx, contB)



/// Encases the functor map operation ('a -> 'b) -> Cell<'a> -> Cell<'b>
[<AbstractClass>]  
type CellMap<'a, 'b> () =
  inherit Cell<'b> ()
  
  [<DefaultValue>] 
  val mutable cellA : Cell<'a>
  
  member __.Init (c:Cell<'a>) =
    __.cellA <- c

  abstract DoMap : 'a -> 'b
  
  override __.RunCell (ctx:ExecContext, cont:Cont<'b>) = 
    __.cellA.RunCell (ctx, CellMapCont(__, cont))

and CellMapCont<'a, 'b> (cb:CellMap<'a, 'b>, contB:Cont<'b>) =
  inherit Cont<'a> ()
  override __.RunCont (ctx, a:'a) =
    contB.RunCont (ctx, cb.DoMap a)

[<AbstractClass>]
type CellDelay<'a> () =
  inherit Cell<'a> ()
  abstract DoDelay : unit -> Cell<'a>
  override __.RunCell (ctx:ExecContext, cont:Cont<'a>) =
    __.DoDelay().RunCell(ctx,cont)



type CellAsync<'a> (a:Async<'a>) =
  inherit Cell<'a> ()
  override __.RunCell (ctx:ExecContext, cont:Cont<'a>) =
    let ok a = cont.RunCont (ctx,a)
    let err (e:#exn) = ()
    Async.StartWithContinuations (a, ok, err, err)



module Cell =

  let point (a:'a) : Cell<'a> =
    { new Cell<'a> () with override __.RunCell (ctx,cont) = cont.RunCont (ctx,a) }

  let map (f:'a -> 'b) (c:Cell<'a>) : Cell<'b> =
    let cm = { new CellMap<'a, 'b> () with override __.DoMap a = f a }
    cm.Init c
    cm :> _

  let bind (f:'a -> Cell<'b>) (c:Cell<'a>) : Cell<'b> =
    let cb = { new CellBind<'a, 'b> () with override __.DoBind a = f a }
    cb.Init c
    cb :> _

  let delay (f:unit -> Cell<'a>) : Cell<'a> =
    { new Cell<'a> () with
        override __.RunCell (ctx,cont) =
          let c = f ()
          c.RunCell (ctx,cont) }
  
  let run (c:Cell<'a>) : 'a =
    let mutable res = Unchecked.defaultof<_>
    let mre = new System.Threading.ManualResetEvent(false)
    let ctx = new ExecContext()
    let cont = 
      { new Cont<'a> () with
          override __.RunCont (ctx,a) = 
            res <- a
            mre.Set () |> ignore
            () }
    c.RunCell (ctx, cont)
    mre.WaitOne() |> ignore
    res

  let ofAsync (a:Async<'a>) : Cell<'a> =
    CellAsync<'a> (a) :> _

  type Builder () =
    member __.Bind (c:Cell<'a>, f:'a -> Cell<'b>) = bind f c
    member __.Return (a:'a) = point a
    member __.Delay (f:unit -> Cell<'a>) = delay f

[<AutoOpen>]
module CellEx =  
  
  let cell = new Cell.Builder ()


let wfB = cell {  
  return 100
}

let wfA = cell {
  let! a = wfB
  let! b = Cell.ofAsync (Async.Sleep 100)
  return a + 2
}

let result = Cell.run wfA

printfn "%A" result