Monadic Trampoline

A monadic trampoline for stack-overflow free programming.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56:

type TrampValue<'T> =
    | DelayValue of Delay<'T>
    | ReturnValue of Return<'T>
    | BindValue of IBind<'T>
and ITramp<'T> = 
    abstract member Value : TrampValue<'T>
    abstract member Run : unit -> 'T

and Delay<'T>(f : unit -> ITramp<'T>) =
    member self.Func = f 
    interface ITramp<'T> with
        member self.Value = DelayValue self
        member self.Run () = (f ()).Run()

and Return<'T>(x :'T) = 
    member self.Value = x
    interface ITramp<'T> with
        member self.Value = ReturnValue self
        member self.Run () = x

and IBind<'T> = 
    abstract Bind<'R> : ('T -> ITramp<'R>) -> ITramp<'R>
and Bind<'T, 'R>(tramp : ITramp<'T>, f : ('T -> ITramp<'R>)) = 
    interface IBind<'R> with
        member self.Bind<'K>(f' : 'R -> ITramp<'K>) : ITramp<'K> =
            new Bind<'T, 'K>(tramp, fun t -> new Bind<'R, 'K>(f t, (fun r -> f' r)) :> _) :> _
    interface ITramp<'R> with
        member self.Value = BindValue self
        member self.Run () = 
            match tramp.Value with
            | BindValue b -> b.Bind(f).Run() 
            | ReturnValue r -> (f r.Value).Run()
            | DelayValue d -> (new Bind<'T, 'R>(d.Func (), f) :> ITramp<'R>).Run() 

// Builder
type TrampBuilder() = 
    member self.Return a = new Return<_>(a) :> ITramp<_>
    member self.Bind(tramp, f) = 
        new Bind<'T, 'R>(tramp, f) :> ITramp<'R>
    member self.Delay f = 
        new Delay<_>(f) :> ITramp<_>
   
let tramp = new TrampBuilder()

let run (tramp : ITramp<'T>) = tramp.Run()

// Example
let rec inc a = 
    tramp {
        if a = 1 then return 1
        else
            let! x = inc (a - 1)
            return x + 1
    } 

inc 1000000 |> run

union case TrampValue.DelayValue: Delay<'T> -> TrampValue<'T>

Multiple items
type Delay<'T> =
  interface ITramp<'T>
  new : f:(unit -> ITramp<'T>) -> Delay<'T>
  member Func : (unit -> ITramp<'T>)

Full name: Script.Delay<_>

--------------------
new : f:(unit -> ITramp<'T>) -> Delay<'T>

union case TrampValue.ReturnValue: Return<'T> -> TrampValue<'T>

Multiple items
type Return<'T> =
  interface ITramp<'T>
  new : x:'T -> Return<'T>
  member Value : 'T

Full name: Script.Return<_>

--------------------
new : x:'T -> Return<'T>

union case TrampValue.BindValue: IBind<'T> -> TrampValue<'T>

type IBind<'T> =
  interface
    abstract member Bind : ('T -> ITramp<'R>) -> ITramp<'R>
  end

Full name: Script.IBind<_>

type ITramp<'T> =
  interface
    abstract member Run : unit -> 'T
    abstract member Value : TrampValue<'T>
  end

Full name: Script.ITramp<_>

abstract member ITramp.Value : TrampValue<'T>

Full name: Script.ITramp`1.Value

type TrampValue<'T> =
  | DelayValue of Delay<'T>
  | ReturnValue of Return<'T>
  | BindValue of IBind<'T>

Full name: Script.TrampValue<_>

abstract member ITramp.Run : unit -> 'T

Full name: Script.ITramp`1.Run

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val f : (unit -> ITramp<'T>)

val self : Delay<'T>

member Delay.Func : (unit -> ITramp<'T>)

Full name: Script.Delay`1.Func

override Delay.Value : TrampValue<'T>

Full name: Script.Delay`1.Value

override Delay.Run : unit -> 'T

Full name: Script.Delay`1.Run

val x : 'T

val self : Return<'T>

member Return.Value : 'T

Full name: Script.Return`1.Value

override Return.Value : TrampValue<'T>

Full name: Script.Return`1.Value

override Return.Run : unit -> 'T

Full name: Script.Return`1.Run

Multiple items
abstract member IBind.Bind : ('T -> ITramp<'R>) -> ITramp<'R>

Full name: Script.IBind`1.Bind

--------------------
type Bind<'T,'R> =
  interface ITramp<'R>
  interface IBind<'R>
  new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Full name: Script.Bind<_,_>

--------------------
new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Multiple items
type Bind<'T,'R> =
  interface ITramp<'R>
  interface IBind<'R>
  new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Full name: Script.Bind<_,_>

--------------------
new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

val tramp : ITramp<'T>

val f : ('T -> ITramp<'R>)

val self : Bind<'T,'R>

Multiple items
override Bind.Bind : f':('R -> ITramp<'K>) -> ITramp<'K>

Full name: Script.Bind`2.Bind

--------------------
type Bind<'T,'R> =
  interface ITramp<'R>
  interface IBind<'R>
  new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Full name: Script.Bind<_,_>

--------------------
new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

val f' : ('R -> ITramp<'K>)

val t : 'T

val r : 'R

override Bind.Value : TrampValue<'R>

Full name: Script.Bind`2.Value

override Bind.Run : unit -> 'R

Full name: Script.Bind`2.Run

property ITramp.Value: TrampValue<'T>

val b : IBind<'T>

abstract member IBind.Bind : ('T -> ITramp<'R>) -> ITramp<'R>

val r : Return<'T>

property Return.Value: 'T

val d : Delay<'T>

property Delay.Func: unit -> ITramp<'T>

Multiple items
type TrampBuilder =
  new : unit -> TrampBuilder
  member Bind : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> ITramp<'R>
  member Delay : f:(unit -> ITramp<'a>) -> ITramp<'a>
  member Return : a:'b -> ITramp<'b>

Full name: Script.TrampBuilder

--------------------
new : unit -> TrampBuilder

val self : TrampBuilder

Multiple items
member TrampBuilder.Return : a:'b -> ITramp<'b>

Full name: Script.TrampBuilder.Return

--------------------
type Return<'T> =
  interface ITramp<'T>
  new : x:'T -> Return<'T>
  member Value : 'T

Full name: Script.Return<_>

--------------------
new : x:'T -> Return<'T>

val a : 'b

Multiple items
member TrampBuilder.Bind : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> ITramp<'R>

Full name: Script.TrampBuilder.Bind

--------------------
type Bind<'T,'R> =
  interface ITramp<'R>
  interface IBind<'R>
  new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Full name: Script.Bind<_,_>

--------------------
new : tramp:ITramp<'T> * f:('T -> ITramp<'R>) -> Bind<'T,'R>

Multiple items
member TrampBuilder.Delay : f:(unit -> ITramp<'a>) -> ITramp<'a>

Full name: Script.TrampBuilder.Delay

--------------------
type Delay<'T> =
  interface ITramp<'T>
  new : f:(unit -> ITramp<'T>) -> Delay<'T>
  member Func : (unit -> ITramp<'T>)

Full name: Script.Delay<_>

--------------------
new : f:(unit -> ITramp<'T>) -> Delay<'T>

val f : (unit -> ITramp<'a>)

val tramp : TrampBuilder

Full name: Script.tramp

val run : tramp:ITramp<'T> -> 'T

Full name: Script.run

abstract member ITramp.Run : unit -> 'T

val inc : a:int -> ITramp<int>

Full name: Script.inc

val a : int

val x : int

Raw view Test code New version

More information

Link:	http://fssnip.net/dK
Posted:	12 years ago
Author:	Nick Palladinos
Tags:	monad , trampoline