5 people like it.

A very simple free monad

You might have heard that a "free" monad can be created from any functor. Unfortunately, that doesn't mean much if you're not already familiar with category theory. This example creates a free monad from a simple functor types

 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: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
90: 
91: 
92: 
/// Canonical list definition, just for comparison.
type List<'item> =
    | Cons of 'item * List<'item>
    | Nil

/// A link consists of an item followed by a tail of some type.
type Link<'item, 'tail> =

    /// Just like Cons, but not recursive.
    | Link of 'item * 'tail

    /// Just like Nil.
    | Done

module Link =

    /// An example of length 0.
    let example0 = Done

    /// An example of length 1.
    let example1 = Link ('A', Done)

    /// An example of length 2.
    let example2 = Link ('A', Link ('B', Done))

    /// We can map over a link (which means it's a functor). Since the item
    /// and the tail are two different types, we choose to leave the item
    /// alone and map over the tail.
    let map f = function
        | Link (item, tail) -> Link (item, f tail)
        | Done -> Done

/// A recursive chain of links (i.e. its free monad).
type Chain<'item, 'next> =

    /// Link's "fixed point".
    | Free of Link<'item, Chain<'item, 'next>>

    /// Lifts a value directly into the monad.
    | Pure of 'next

module Chain =

    /// Binds two chains together.
    let rec bind f = function
        | Free link ->
            link
                |> Link.map (bind f)   // pass the given function along to the next link
                |> Free
        | Pure next -> f next          // we're at the end: glue the two chains together

/// Workflow builder for chains.
type ChainBuilder() =
    member __.Bind(chain, func) = chain |> Chain.bind func
    member __.Return(value) = Pure value
    member __.ReturnFrom(value) = value
    member __.Zero() = Pure ()

/// Workflow builder for chains.
let chain = ChainBuilder()

/// Creates a one-link chain with the given item, ready for binding.
let toChain item =
    Free (Link (item, Pure ()))

/// Example: Creates a chain the verbose way.
let chainPlain =
    toChain 'A'
        |> Chain.bind (fun () -> toChain 'B')   // replace chain A's tail with chain B

/// Example: Creates a chain using the builder.
let chainSugar =
    chain {
        do! toChain 'A'
        do! toChain 'B'
        return ()
    }

/// These two chains are the same.
///
/// Output:
/// Free (Link ('A', Free (Link ('B', Pure ()))))
/// Free (Link ('A', Free (Link ('B', Pure ()))))
[<EntryPoint>]
let main argv =
    printfn "%A" chainPlain
    printfn "%A" chainSugar
    0

// For more information:
// * http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html
// * https://blog.ploeh.dk/2017/08/07/f-free-monad-recipe/
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
union case List.Cons: 'item * List<'item> -> List<'item>
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'item> =
  | Cons of 'item * List<'item>
  | Nil

Full name: Script.List<_>


 Canonical list definition, just for comparison.
union case List.Nil: List<'item>
Multiple items
union case Link.Link: 'item * 'tail -> Link<'item,'tail>


 Just like Cons, but not recursive.


--------------------
type Link<'item,'tail> =
  | Link of 'item * 'tail
  | Done

Full name: Script.Link<_,_>


 A link consists of an item followed by a tail of some type.
union case Link.Done: Link<'item,'tail>


 Just like Nil.
type Link<'item,'tail> =
  | Link of 'item * 'tail
  | Done

Full name: Script.Link<_,_>


 A link consists of an item followed by a tail of some type.
val example0 : Link<'a,'b>

Full name: Script.Link.example0


 An example of length 0.
val example1 : Link<char,Link<'a,'b>>

Full name: Script.Link.example1


 An example of length 1.
val example2 : Link<char,Link<char,Link<'a,'b>>>

Full name: Script.Link.example2


 An example of length 2.
val map : f:('a -> 'b) -> _arg1:Link<'c,'a> -> Link<'c,'b>

Full name: Script.Link.map


 We can map over a link (which means it's a functor). Since the item
 and the tail are two different types, we choose to leave the item
 alone and map over the tail.
val f : ('a -> 'b)
val item : 'c
val tail : 'a
type Chain<'item,'next> =
  | Free of Link<'item,Chain<'item,'next>>
  | Pure of 'next

Full name: Script.Chain<_,_>


 A recursive chain of links (i.e. its free monad).
union case Chain.Free: Link<'item,Chain<'item,'next>> -> Chain<'item,'next>


 Link's "fixed point".
Multiple items
union case Link.Link: 'item * 'tail -> Link<'item,'tail>


 Just like Cons, but not recursive.


--------------------
module Link

from Script

--------------------
type Link<'item,'tail> =
  | Link of 'item * 'tail
  | Done

Full name: Script.Link<_,_>


 A link consists of an item followed by a tail of some type.
union case Chain.Pure: 'next -> Chain<'item,'next>


 Lifts a value directly into the monad.
val bind : f:('a -> Chain<'b,'c>) -> _arg1:Chain<'b,'a> -> Chain<'b,'c>

Full name: Script.Chain.bind


 Binds two chains together.
val f : ('a -> Chain<'b,'c>)
val link : Link<'b,Chain<'b,'a>>
val next : 'a
Multiple items
type ChainBuilder =
  new : unit -> ChainBuilder
  member Bind : chain:Chain<'e,'f> * func:('f -> Chain<'e,'g>) -> Chain<'e,'g>
  member Return : value:'c -> Chain<'d,'c>
  member ReturnFrom : value:'b -> 'b
  member Zero : unit -> Chain<'a,unit>

Full name: Script.ChainBuilder


 Workflow builder for chains.


--------------------
new : unit -> ChainBuilder
member ChainBuilder.Bind : chain:Chain<'e,'f> * func:('f -> Chain<'e,'g>) -> Chain<'e,'g>

Full name: Script.ChainBuilder.Bind
val chain : Chain<'e,'f>
val func : ('f -> Chain<'e,'g>)
Multiple items
module Chain

from Script

--------------------
type Chain<'item,'next> =
  | Free of Link<'item,Chain<'item,'next>>
  | Pure of 'next

Full name: Script.Chain<_,_>


 A recursive chain of links (i.e. its free monad).
val __ : ChainBuilder
member ChainBuilder.Return : value:'c -> Chain<'d,'c>

Full name: Script.ChainBuilder.Return
val value : 'c
member ChainBuilder.ReturnFrom : value:'b -> 'b

Full name: Script.ChainBuilder.ReturnFrom
val value : 'b
member ChainBuilder.Zero : unit -> Chain<'a,unit>

Full name: Script.ChainBuilder.Zero
val chain : ChainBuilder

Full name: Script.chain


 Workflow builder for chains.
val toChain : item:'a -> Chain<'a,unit>

Full name: Script.toChain


 Creates a one-link chain with the given item, ready for binding.
val item : 'a
val chainPlain : Chain<char,unit>

Full name: Script.chainPlain


 Example: Creates a chain the verbose way.
val chainSugar : Chain<char,unit>

Full name: Script.chainSugar


 Example: Creates a chain using the builder.
Multiple items
type EntryPointAttribute =
  inherit Attribute
  new : unit -> EntryPointAttribute

Full name: Microsoft.FSharp.Core.EntryPointAttribute

--------------------
new : unit -> EntryPointAttribute
val main : argv:string [] -> int

Full name: Script.main


 These two chains are the same.

 Output:
 Free (Link ('A', Free (Link ('B', Pure ()))))
 Free (Link ('A', Free (Link ('B', Pure ()))))
val argv : string []
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
Raw view Test code New version

More information

Link:http://fssnip.net/7XM
Posted:3 years ago
Author:Brian Berns
Tags: builder , workflow , #functor , #monad , free