/// This is 100% based on tomas petricek blog article.
/// there has been some small additions in regards to adding Result type
/// and handling Monoids for the Writer Part.
/// go check the following blog article : http://tomasp.net/blog/2014/update-monads/
/// Comment appreciated + bear in mind that performance wise, the Monoid Combine operator,
/// could be greatly improved and more.
[]
module Monoid =
type IMonoid<'M> =
abstract member Empty : (unit -> 'M)
abstract member Combine : ('M * 'M -> 'M)
let listMonoid =
{ new IMonoid> with
member __.Empty = fun () -> []
member __.Combine = fun (l1,l2) -> l1 @ l2
}
let arrayMonoid =
{ new IMonoid<'T []> with
member __.Empty = fun () -> [||]
member __.Combine = fun (a1,a2) -> Array.append a1 a2
}
let unitMonoid =
{ new IMonoid<_> with
member __.Empty = fun () -> ()
member __.Combine = fun (_,_) -> ()
}
[]
module UpdateResult =
[]
[]
type Result<'Update, 'T> =
| Success of 'Update * 'T
// It is bad practice to use a string as a failure description
// Let to the user to update the Failure payload to be a proper type or something
// of the sort
| Failure of string
[]
[]
type UpdateMonad<'TState, 'TUpdate, 'T> = UM of ('TState -> Result<'TUpdate, 'T>)
[]
[]
type DelayedUM<'TState, 'TUpdate, 'T> = DelayedUM of (unit -> UpdateMonad<'TState, 'TUpdate, 'T>)
let inline unit< 'T, ^S when ^S : (static member Unit : IMonoid<'T> -> ^S) > (m : IMonoid<'T>) : ^S =
(^S : (static member Unit : IMonoid<'T> -> ^S) (m))
/// Invokes Combine operation on a pair of ^S values
let inline combine< 'T, ^S when ^S : (static member Combine : IMonoid<'T> * ^S * ^S -> ^S ) > m a b : ^S =
(^S : (static member Combine : IMonoid<'T> * ^S * ^S -> ^S) (m, a, b))
/// Invokes Apply operation on state and update ^S * ^U
let inline apply< 'T, ^S, ^U when ^U : (static member Apply : IMonoid<'T> * ^S * ^U -> ^S )> m s a : ^S =
(^U : (static member Apply : IMonoid<'T> * ^S * ^U -> ^S) (m, s, a))
type UpdateBuilder<'M>(monoid: IMonoid<'M>) =
member inline __.Bind(DelayedUM delayed, f:'T -> UpdateMonad<'S, 'U, 'R>) : UpdateMonad<'S, 'U, 'R>=
UM (fun state ->
// Run the first computation to get first update
// 'u1', then run 'f' to get second computation
let (UM update1) = delayed ()
match update1 state with
| Success (update1,value1) ->
let (UM update2) = f value1
// Apply 'u1' to original state & run second computation
// then return result with combined state updates
match update2 (apply monoid state update1) with
| Success (update2,value2) ->
let res = combine monoid update1 update2
Success (res,value2)
| Failure failure -> Failure failure
| Failure failure -> Failure failure
)
member inline __.Return(value:'T) : UpdateMonad<'S, 'U, 'T> =
let update = unit monoid
UM (fun _ -> Success (update,value))
member inline __.ReturnFrom(DelayedUM update : DelayedUM<'S, 'U, 'T>) : UpdateMonad<'S, 'U, 'T> =
update ()
member inline x.Yield(value:'T) : UpdateMonad<'S, 'U, 'T> = x.Return value
member inline x.YieldFrom(delayedUM) = x.ReturnFrom delayedUM
member inline this.Zero() : UpdateMonad<'S, 'U, unit> = this.Return ()
member inline __.Delay(f:unit -> UpdateMonad<'State, 'Update, 'T>) = f
member inline __.Run(f:unit -> UpdateMonad<'State, 'Update, 'T>) = DelayedUM f
member inline this.Combine(update : UpdateMonad<'S, 'U, 'T>, delayedUM : unit -> UpdateMonad<'S, 'U, 'T>) : UpdateMonad<'S, 'U, 'T>=
this.Bind(DelayedUM (fun _ -> update), fun _ -> delayedUM())
member inline this.TryFinally(body, compensation) =
try this.ReturnFrom(body())
finally compensation()
member inline this.TryWith(body : unit -> DelayedUM<'S,'U,'T>, handler: exn -> UpdateMonad<'S, 'U, 'T>) : UpdateMonad<'S, 'U, 'T> =
try this.ReturnFrom(body())
with e -> handler e
member inline this.Using(disposable:#System.IDisposable, body : 'a -> DelayedUM<'S, 'U, 'T>) =
let body' = fun () -> body disposable
this.TryFinally(body', fun () ->
match disposable with
| null -> ()
| disp -> disp.Dispose())
member inline this.While(guard: unit -> bool, body: unit -> UpdateMonad<'S, 'U, unit>) : DelayedUM<'S, 'U, unit> =
let rec loop () =
if guard() then
this.Bind(DelayedUM body, loop)
else
this.Zero()
DelayedUM( fun () -> loop())
member inline this.For(sequence:seq<'a>, body: 'a -> UpdateMonad<'S, 'U, unit>) : UpdateMonad<'S, 'U, unit>=
this.Using(sequence.GetEnumerator(),fun enum ->
this.While(enum.MoveNext,
this.Delay(fun () -> body enum.Current)))
module ReaderResult =
let reader = UpdateBuilder(unitMonoid)
type ReaderUpdate =
| NoUpdate
static member Unit(_:IMonoid<'T>) = NoUpdate
static member Combine(_:IMonoid<'T>, NoUpdate, NoUpdate) = NoUpdate
static member Apply(_:IMonoid<'T>, s, NoUpdate) = s
/// Read the current state (int) and return it as 'int'
let read = DelayedUM ( fun() -> UM (fun (s:'T) -> Success (NoUpdate, s)) )
/// Run computation and return the result
let readRun (s:'T) (DelayedUM f) =
let (UM update) = f()
update s
/// Returns state + 1
let demo1 = reader {
let! v = read
printfn "side effect"
return v + 1
}
/// Returns the result of demo1 + 1
let demo2 = reader {
printfn "hello"
let! v = demo1
return v + 1
}
// Run it with state 40
let resRead = demo2 |> readRun 40
module WriterResult =
/// Writer monad has no readable state
type WriterState = NoState
type WriterUpdate<'M> =
| WU of 'M
static member Unit(monoid : IMonoid<'T>) = WU (monoid.Empty())
static member Combine(monoid : IMonoid<'T>, WU m1, WU m2) = WU (monoid.Combine(m1,m2))
/// Applying updates to state does not affect the state
static member Apply(_ : IMonoid<'T>, NoState, _) = NoState
let inline write value =
DelayedUM( fun () -> UM (fun _ -> Success (WU value, ())))
/// Runs a "writer monad computation" and returns
let writeRun (DelayedUM delayed) =
let (UM update) = delayed()
update NoState
let writerList () = UpdateBuilder<'a list>(listMonoid)
let inline writeList value = write value
let demoWriter =
writerList () {
for i in 1..10 do
do! writeList [i]
}
let resWriter = demoWriter |> writeRun
module StateResult =
/// Wraps a state of type 'T
type StateState<'T> = State of 'T
/// Represents updates on state of type 'T
type StateUpdate<'T> =
| Set of 'T
| SetNop
/// Empty update - do not change the state
static member Unit(_ : IMonoid<'T>) = SetNop
/// Combine updates - return the latest (rightmost) 'Set' update
static member Combine(_ : IMonoid<'T>, a, b) =
match a, b with
| SetNop, v | v, SetNop -> v
| Set _ , Set b -> Set b
/// Apply update to a state - the 'Set' update changes the state
static member Apply(_ : IMonoid<'T>, s, p) =
match p with
| SetNop -> s
| Set s -> State s
/// Put the state to the specified value
let put s = UM (fun _ -> Success (Set s,()))
/// Get the current state
let get = UM (fun (State s) -> Success (SetNop, s))
/// Run a computation using a specified initial state
let setRun s (UM f) = f (State s)