Skip to content

Instantly share code, notes, and snippets.

@mattpodwysocki
Created February 2, 2010 04:53
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save mattpodwysocki/292392 to your computer and use it in GitHub Desktop.
Save mattpodwysocki/292392 to your computer and use it in GitHub Desktop.
open System
open System.Collections.Generic
type IMonoid<'T> =
abstract member mempty : unit -> 'T
abstract member mappend : 'T * 'T -> 'T
type MonoidAssociations private() =
static let associations = new Dictionary<Type, obj>()
static member Add<'T>(monoid : IMonoid<'T>) = associations.Add(typeof<'T>, monoid)
static member Get<'T>() =
match associations.TryGetValue(typeof<'T>) with
| true, assoc -> assoc :?> IMonoid<'T>
| false, _ -> failwithf "Type %O does not have an implementation of IMonoid" <| typeof<'T>
let mempty<'T> = MonoidAssociations.Get<'T>().mempty
let mappend<'T> a b = MonoidAssociations.Get<'T>().mappend(a, b)
type ListMonoid<'T>() =
interface IMonoid<'T list> with
member this.mempty() = []
member this.mappend(a, b) = a @ b
MonoidAssociations.Add(new ListMonoid<string>())
type Writer<'W,'T> = Writer of (unit -> 'T * 'W)
let runWriter<'W,'T> (Writer t) : ('T * 'W) = t()
type WriterBuilder() =
member this.Return<'W,'T>(a : 'T) : Writer<'W,'T> =
Writer(fun () -> a, mempty())
member this.ReturnFrom<'W,'T>(w : Writer<'W,'T>) = w
member this.Bind<'W,'T,'U>(m : Writer<'W,'T>, k : 'T -> Writer<'W,'U>) : Writer<'W,'U> =
Writer(fun () ->
let (a, w) = runWriter m
let (b, w') = runWriter (k a)
in (b, mappend<'W> w w'))
member this.Zero<'W>() : Writer<'W,unit> = this.Return ()
member this.TryWith<'W,'T>(writer : Writer<'W,'T>, handler : exn -> Writer<'W,'T>) =
Writer(fun () ->
try runWriter writer
with e -> runWriter (handler e))
member this.TryFinally<'W,'T>(writer : Writer<'W,'T>, compensation : unit -> unit) =
Writer(fun () ->
try runWriter writer
finally compensation())
member this.Using<'D,'W,'T when 'D :> IDisposable and 'D : null>(resource : 'D, body : 'D -> Writer<'W,'T>) =
this.TryFinally(body resource, (fun () -> match resource with null -> () | disp -> disp.Dispose()))
member this.Delay<'W,'T>(f : unit -> Writer<'W,'T>) =
this.Bind(this.Return (), f)
member this.Combine<'W,'T>(comp1 : Writer<'W,unit>, comp2 : Writer<'W,'T>) =
this.Bind(comp1, (fun () -> comp2))
member this.While<'W>(pred : unit -> bool, body : Writer<'W,unit>) =
match pred() with
| true -> this.Bind(body, (fun () -> this.While(pred,body)))
| _ -> this.Return ()
member this.For<'W,'T>(items : seq<'T>, body : 'T -> Writer<'W,unit>) =
this.Using(items.GetEnumerator(),
(fun enum -> this.While((fun () -> enum.MoveNext()), this.Delay(fun () -> body enum.Current))))
let writer = new WriterBuilder()
let tell w = Writer(fun () -> (), w)
let listen m = Writer(fun () -> let (a, w) = runWriter m in ((a, w), w))
let pass m = Writer(fun () -> let ((a, f), w) = runWriter m in (a, f w))
let listens f m = writer {
let! (a,w) = m
return (a, f w) }
let censor f m =
writer { let! a = m
return (a, f)
} |> pass
let logMsg (s : string) = tell [s]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment