4 people like it.

Free-monad interpreter

Re-hash of the Free-monad interpreter by erdeszt https://gist.github.com/erdeszt/f8b351b5e6ec4fd903ef based on http://programmers.stackexchange.com/a/242803/145941

 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: 
57: 
58: 
59: 
60: 
61: 
62: 
// Free monad-interpreter in F# (based on: http://programmers.stackexchange.com/a/242803/145941)

type DSL<'next> =
    | Get of key: string *       (string -> 'next)
    | Set of key: string * value: string *  'next

let mapDSL: ('a -> 'b) -> DSL<'a> -> DSL<'b> = 
    fun     f          ->
        function
        | Get (k,    c) -> Get (k,      c >> f)
        | Set (k, v, c) -> Set (k, v, f c     )

type FreeDSL<'a> =
    | Free   of DSL<FreeDSL<'a>>
    | Return of 'a

let rec bindFree: ('a -> FreeDSL<'b>) -> (FreeDSL<'a>) -> FreeDSL<'b> =
    fun           f                   ->
       function
       | Return a   -> f a
       | Free   dsl -> Free (mapDSL (bindFree f) dsl)

let ex1  = Set ("alma", "bela", (Get ("alma", id)))
let exF1 = Free (Set ("alma", "bela", (Free (Get ("alma", (fun s -> Return s))))))

type FreeDSLBuilder () =
    member this.Return     x = Return x
    member this.ReturnFrom x = x
    member this.Zero      () = Return ()
    member this.Bind (ma, f) = bindFree f ma

let domain = FreeDSLBuilder ()

let liftFree: DSL<'a> -> FreeDSL<'a> =
    fun       action  -> Free (mapDSL Return action)

let get key       = liftFree (Get (key, id))
let set key value = liftFree (Set (key, value, ()))
//let end'<'a>      = liftFree End

let exF2 = domain.Bind(set "foo" "bar", (fun _ -> get "foo"))

let exF3 = domain {
    let! value  = get "foo"
    do! set "bar" value
    get "bar" |> ignore
}


let rec interpreter: ('a -> unit) -> FreeDSL<'a> -> unit =
    fun              receiver        free        ->
        match free with
        | Free(Get(key,        nextF)) -> printfn "Get %s" key
                                          nextF (sprintf "'get.%s'" key) |> interpreter receiver
        | Free(Set(key, value, next )) -> printfn "Set %s = %s" key value
                                          next                           |> interpreter receiver
        | Return v                     -> printfn "return(%A)" v
                                          receiver v

interpreter (printfn "Received: %A") exF1
interpreter (printfn "Received: %A") exF2
interpreter (printfn "Received: %A") exF3
union case DSL.Get: key: string * (string -> 'next) -> DSL<'next>
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
Multiple items
union case DSL.Set: key: string * value: string * 'next -> DSL<'next>

--------------------
module Set

from Microsoft.FSharp.Collections

--------------------
type Set<'T (requires comparison)> =
  interface IComparable
  interface IEnumerable
  interface IEnumerable<'T>
  interface ICollection<'T>
  new : elements:seq<'T> -> Set<'T>
  member Add : value:'T -> Set<'T>
  member Contains : value:'T -> bool
  override Equals : obj -> bool
  member IsProperSubsetOf : otherSet:Set<'T> -> bool
  member IsProperSupersetOf : otherSet:Set<'T> -> bool
  ...

Full name: Microsoft.FSharp.Collections.Set<_>

--------------------
new : elements:seq<'T> -> Set<'T>
val mapDSL : f:('a -> 'b) -> _arg1:DSL<'a> -> DSL<'b>

Full name: Script.mapDSL
type DSL<'next> =
  | Get of key: string * (string -> 'next)
  | Set of key: string * value: string * 'next

Full name: Script.DSL<_>
val f : ('a -> 'b)
val k : string
val c : (string -> 'a)
val v : string
val c : 'a
type FreeDSL<'a> =
  | Free of DSL<FreeDSL<'a>>
  | Return of 'a

Full name: Script.FreeDSL<_>
union case FreeDSL.Free: DSL<FreeDSL<'a>> -> FreeDSL<'a>
union case FreeDSL.Return: 'a -> FreeDSL<'a>
val bindFree : f:('a -> FreeDSL<'b>) -> _arg1:FreeDSL<'a> -> FreeDSL<'b>

Full name: Script.bindFree
val f : ('a -> FreeDSL<'b>)
val a : 'a
val dsl : DSL<FreeDSL<'a>>
val ex1 : DSL<DSL<string>>

Full name: Script.ex1
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val exF1 : FreeDSL<string>

Full name: Script.exF1
val s : string
Multiple items
type FreeDSLBuilder =
  new : unit -> FreeDSLBuilder
  member Bind : ma:FreeDSL<'a> * f:('a -> FreeDSL<'b>) -> FreeDSL<'b>
  member Return : x:'d -> FreeDSL<'d>
  member ReturnFrom : x:'c -> 'c
  member Zero : unit -> FreeDSL<unit>

Full name: Script.FreeDSLBuilder

--------------------
new : unit -> FreeDSLBuilder
val this : FreeDSLBuilder
member FreeDSLBuilder.Return : x:'d -> FreeDSL<'d>

Full name: Script.FreeDSLBuilder.Return
val x : 'd
member FreeDSLBuilder.ReturnFrom : x:'c -> 'c

Full name: Script.FreeDSLBuilder.ReturnFrom
val x : 'c
member FreeDSLBuilder.Zero : unit -> FreeDSL<unit>

Full name: Script.FreeDSLBuilder.Zero
member FreeDSLBuilder.Bind : ma:FreeDSL<'a> * f:('a -> FreeDSL<'b>) -> FreeDSL<'b>

Full name: Script.FreeDSLBuilder.Bind
val ma : FreeDSL<'a>
val domain : FreeDSLBuilder

Full name: Script.domain
val liftFree : action:DSL<'a> -> FreeDSL<'a>

Full name: Script.liftFree
val action : DSL<'a>
val get : key:string -> FreeDSL<string>

Full name: Script.get
val key : string
val set : key:string -> value:string -> FreeDSL<unit>

Full name: Script.set
val value : string
val exF2 : FreeDSL<string>

Full name: Script.exF2
member FreeDSLBuilder.Bind : ma:FreeDSL<'a> * f:('a -> FreeDSL<'b>) -> FreeDSL<'b>
val exF3 : FreeDSL<unit>

Full name: Script.exF3
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
val interpreter : receiver:('a -> unit) -> free:FreeDSL<'a> -> unit

Full name: Script.interpreter
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val receiver : ('a -> unit)
val free : FreeDSL<'a>
val nextF : (string -> FreeDSL<'a>)
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
val next : FreeDSL<'a>
val v : 'a

More information

Link:http://fssnip.net/7SX
Posted:7 years ago
Author:amieres
Tags: interpreter , freemonad