gistfile1.fs

module Free

type Generic<'T, 'TypeClass when 'TypeClass : (new : unit -> 'TypeClass)> = interface end

type [<AbstractClass>] FunctorClass<'FunctorClass when 'FunctorClass :> FunctorClass<'FunctorClass> 
                                                  and  'FunctorClass : (new : unit -> 'FunctorClass)>() = 
    abstract FMap<'T, 'R> : ('T -> 'R) -> Generic<'T, 'FunctorClass> -> Generic<'R, 'FunctorClass>

type Free<'a,'f when 
                'f :> FunctorClass<'f>
                and 'f : (new: unit -> 'f)>
                = Pure of 'a | Roll of Generic<Free<'a,'f>,'f>

module Free = 
    let return' x = Pure x

    let bind f m = 
                    let rec bind (f:'a->Free<'d,'f>) 
                                 (m:Free<'a,'f>)
                                 :Free<'d,'f> =
                                    match m with 
                                    | Pure (v) -> f v
                                    | Roll (gen:Generic<_,'f>) ->
                                          let fmap = (new 'f()).FMap
                                          let map=fmap (bind f) (gen)
                                          map |> Roll
                    bind f m

type DSL<'next> = 
            | Echo of int * (int -> 'next)
            | Stringify of int * (string -> 'next)
    with interface Generic<'next,DSLFunctor>
and DSLFunctor() =
    inherit FunctorClass<DSLFunctor>()
    override x.FMap f a = match a :?> _ with
                          | Echo (int,next)-> Echo(int,next>>f) :> _
                          | Stringify (int,next) -> Stringify(int,next>>f) :>_

module DSL =

        let Stop<'a> (x:'a) = Pure x
        let echo x= Echo (x,Stop) :> Generic<_,DSLFunctor> |> Roll
        let tostring x = Stringify(x,Stop) :> Generic<_,DSLFunctor> |> Roll


        let testprogram = Free.return' 1 |> Free.bind echo |> Free.bind (fun x -> x+10 |> Free.return') |> Free.bind tostring
        let testprogram2 = Free.return' 2 |> Free.bind echo |> Free.bind echo |> Free.bind tostring


module DSLInterpreter = 

    let rec interpret (program: Free<'a,DSLFunctor>) : 'a = 
                match program with
                | Pure x -> x
                | Roll (cmd) -> match cmd :?> DSL<_> with
                                | Echo (arg,next) -> next arg |> interpret
                                | Stringify (arg,next) -> (string arg) |> next |> interpret

    let example1 = interpret DSL.testprogram
    let example2 = interpret DSL.testprogram2

type DSL2<'result> =
        | NoOp of unit * (unit -> 'result)
        with interface Generic<'result,DSL2Functor>
and DSL2Functor() = 
    inherit FunctorClass<DSL2Functor>()
    override x.FMap f a = match a:?> _ with
                          | NoOp (unit,next) -> NoOp(unit,next>>f) :> _

module DSL2 = 
        let Stop<'a> (x:'a) = Pure x

        let noop () = NoOp ((),Stop) :> Generic<_,DSL2Functor> |> Roll

        let spinprogram = Free.return' () |> Free.bind noop |> Free.bind noop