effectful.fs

module Effective =
  open System

  type [<Struct>] Continuation<'T> = Continuation of ('T -> unit)

  type [<Struct>] Result<'T> =
    | Immediate of v:'T
    | Delayed   of f:(Continuation<'T> -> Continuation<exn> -> unit)

  type [<Struct>] Effect<'T, 'U> = Effect of ('T -> Result<'U>)

  type [<Struct>] Effectful<'T, 'U, 'V> = Effectful of (Effect<'U, 'V> -> Result<'T>)

  module Effectful =
    module Details =
      let inline adapte   (Effectful f)     = f
      let inline invokee  f e               = f e

      let inline adaptc   (Continuation c)  = c
      let inline invokec  c v               = c v

      let inline adapt2  f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
      let inline invoke2 (f : OptimizedClosures.FSharpFunc<_, _, _>) a b  = f.Invoke (a, b)

      let inline tryWith bc a =
        try
          a ()
        with
        | e ->
          bc e


    open Details

    let ereturn v : Effectful<_, _, _> =
      Effectful <| fun e ->
        Immediate v

    let ebind t uf : Effectful<_, _, _> =
      let t = adapte t
      Effectful <| fun e ->
        match invokee t e with
        | Immediate tv ->
          let u = uf tv
          let u = adapte u
          u e
        | Delayed tf ->
          let tf = adapt2 tf
          Delayed <| fun gc bc ->
            let tc tv =
              let u = uf tv
              let u = adapte u
              match invokee u e with
              | Immediate uv ->
                let gc = adaptc gc
                invokec gc uv
              | Delayed uf ->
                let uf = adapt2 uf
                let uc uv =
                  let gc = adaptc gc
                  invokec gc uv
                invoke2 uf (Continuation uc) bc
            invoke2 tf (Continuation tc) bc
              
    let ekeepRight t u : Effectful<_, _, _> =
      // TODO: Optimize
      ebind t (fun _ -> u)

    let eapply f t : Effectful<_, _, _> =
      // TODO: Optimize
      ebind f (fun fv -> ebind t (fun tv -> ereturn (fv tv)))

    let emap m t : Effectful<_, _, _> =
      // TODO: Optimize
      ebind t (fun tv -> ereturn (m tv))

    let erun t h gc bc =
      let t = adapte t
      match invokee t h with
      | Immediate tv ->
        tryWith bc <| fun () ->
          let gc = adaptc gc
          invokec gc tv
      | Delayed tf ->
        let bc_ = adaptc bc
        tryWith bc_ <| fun () ->
          let tf = adapt2 tf
          invoke2 tf gc bc

    type Builder () =
      member inline x.Bind    (t, uf) = ebind       t uf
      member inline x.Combine (t, u)  = ekeepRight  t u
      member inline x.Return  v       = ereturn     v

    module Tasks =
      open System.Threading
      open System.Threading.Tasks

      exception NoResultException of Task

      let etask (t : Task<'T>) : Effectful<'T, _, _> =
        Effectful <| fun e ->
          if t.IsCompleted then
            Immediate t.Result
          else if t.IsFaulted then
            raise t.Exception
          else if t.IsCanceled then
            raise <| TaskCanceledException ()
          else
            Delayed <| fun gc bc ->
              let gc = adaptc gc
              let bc = adaptc bc
              if t.IsCompleted then
                invokec gc t.Result
              else if t.IsFaulted then
                invokec bc t.Exception
              else if t.IsCanceled then
                invokec bc <| TaskCanceledException ()
              else
                let cw (t : Task<'T>) =
                  tryWith bc <| fun () ->
                    if t.IsCompleted then
                      invokec gc t.Result
                    else if t.IsFaulted then
                      invokec bc t.Exception
                    else if t.IsCanceled then
                      invokec bc <| TaskCanceledException ()
                    else
                      invokec bc <| (NoResultException t)
                t.ContinueWith (Action<Task<'T>> cw) |> ignore

  type Effectful<'T, 'U, 'V> with
    static member inline (>>=) (t, uf)  = Effectful.ebind       t uf
    static member inline (>>.) (t, uf)  = Effectful.ekeepRight  t uf
    static member inline (<*>) (f, t)   = Effectful.eapply      f t
    static member inline (|>>) (t, m)   = Effectful.emap        m t

[<EntryPoint>]
let main argv = 
  printfn "%A" argv
  0 // return an integer exit code